diff --git a/compiler/src/codegen/compcore.re b/compiler/src/codegen/compcore.re index d2cef90bca..fcc43cfd25 100644 --- a/compiler/src/codegen/compcore.re +++ b/compiler/src/codegen/compcore.re @@ -1,4 +1,5 @@ open Grain_typed; +open Grain_middle_end; open Mashtree; open Linkedtree; open Value_tags; @@ -505,6 +506,13 @@ let tee_swap = (~ty as typ=Types.GrainValue, wasm_mod, env, idx, value) => ); }; +let imm = i => { + immediate_desc: i, + immediate_analyses: { + last_usage: Unknown, + }, +}; + let rec compile_imm = (wasm_mod, env: codegen_env, i: immediate): Expression.t => switch (i.immediate_desc) { | MImmConst(c) => compile_const(wasm_mod, c) @@ -537,14 +545,8 @@ let allocate_adt = (wasm_mod, env, type_hash, ttag, vtag, elts) => { }; let call_error_handler = (wasm_mod, env, err, args) => { - let imm = i => { - immediate_desc: i, - immediate_analyses: { - last_usage: Unknown, - }, - }; - // Use a special hash value for exceptions + let type_hash = imm(MImmConst(MConstSimpleNumber(0l))); let ty_id = imm( @@ -628,15 +630,6 @@ let compile_tuple_op = (wasm_mod, env, tup_imm, op) => { }; }; -let compile_box_op = (wasm_mod, env, box_imm, op) => - /* At the moment, we make no runtime distinction between boxes and tuples */ - switch (op) { - | MBoxUnbox => - compile_tuple_op(wasm_mod, env, box_imm, MTupleGet(Int32.zero)) - | MBoxUpdate(imm) => - compile_tuple_op(wasm_mod, env, box_imm, MTupleSet(Int32.zero, imm)) - }; - let compile_array_op = (wasm_mod, env, arr_imm, op) => { let get_swap = (~ty=?, n) => get_swap(~ty?, wasm_mod, env, n); let set_swap = (~ty=?, n) => set_swap(~ty?, wasm_mod, env, n); @@ -858,6 +851,14 @@ let compile_record_op = (wasm_mod, env, rec_imm, op) => { }; }; +let compile_box_op = (wasm_mod, env, box_imm, op) => + switch (op) { + | MBoxUnbox => + compile_record_op(wasm_mod, env, box_imm, MRecordGet(Int32.zero)) + | MBoxUpdate(imm) => + compile_record_op(wasm_mod, env, box_imm, MRecordSet(Int32.zero, imm)) + }; + let compile_closure_op = (wasm_mod, env, closure_imm, op) => { let closure = () => compile_imm(wasm_mod, env, closure_imm); switch (op) { @@ -1197,10 +1198,6 @@ let allocate_uninitialized_tuple = (wasm_mod, env, num_elts) => { ); }; -let allocate_box = (wasm_mod, env, elt) => - /* At the moment, we make no runtime distinction between boxes and tuples */ - allocate_tuple(wasm_mod, env, [elt]); - let allocate_uninitialized_wasm_array_any_ref = (wasm_mod, env, num_elts, initial_value) => { Expression.Array.new_( @@ -1272,6 +1269,27 @@ let allocate_record = (wasm_mod, env, type_hash, ttag, elts) => { ); }; +let allocate_box = (wasm_mod, env, elt) => { + let raw_type_hash = + Int32.of_int(Linearize.get_type_hash(Builtin_types.decl_box)); + let type_hash = imm(MImmConst(MConstSimpleNumber(raw_type_hash))); + let ty_id = + imm( + MImmConst( + MConstSimpleNumber( + Int32.of_int(Path.stamp(Builtin_types.path_box)), + ), + ), + ); + allocate_record( + wasm_mod, + env, + type_hash, + ty_id, + [(Builtin_types.ident_box_value, elt)], + ); +}; + type alloc_alt_num_type = | Int32(Expression.t) | Float32(Expression.t) diff --git a/compiler/src/typed/builtin_types.re b/compiler/src/typed/builtin_types.re index a16b72f316..8b2cb1f1f2 100644 --- a/compiler/src/typed/builtin_types.re +++ b/compiler/src/typed/builtin_types.re @@ -63,6 +63,7 @@ and ident_bytes = ident_create("Bytes") and ident_char = ident_create("Char") and ident_void = ident_create("Void") and ident_box = ident_create("Box") +and ident_box_value = ident_create("_value") and ident_array = ident_create("Array") and ident_assertion_error = ident_create_predef_exn("AssertionError") and ident_index_out_of_bounds = ident_create_predef_exn("IndexOutOfBounds") @@ -251,6 +252,15 @@ and decl_box = { ...decl_abstr(GrainValue, path_box), type_params: [tvar], type_arity: 1, + type_kind: + TDataRecord([ + { + rf_name: ident_box_value, + rf_type: tvar, + rf_mutable: true, + rf_loc: Location.dummy_loc, + }, + ]), }; } and decl_array = { diff --git a/compiler/test/__snapshots__/basic_functionality.2bcc447b.0.snapshot b/compiler/test/__snapshots__/basic_functionality.2bcc447b.0.snapshot index 02dd1707d0..011546c0d2 100644 --- a/compiler/test/__snapshots__/basic_functionality.2bcc447b.0.snapshot +++ b/compiler/test/__snapshots__/basic_functionality.2bcc447b.0.snapshot @@ -76,7 +76,7 @@ basic functionality › assert2 (immediate_analyses ((last_usage Unknown)))) ((immediate_desc (MImmConst (MConstSimpleNumber 30))) (immediate_analyses ((last_usage Unknown)))) - ((immediate_desc (MImmConst (MConstSimpleNumber 33))) + ((immediate_desc (MImmConst (MConstSimpleNumber 34))) (immediate_analyses ((last_usage Unknown)))) (((immediate_desc (MImmBinding (MLocalBind 2 GrainValue))) (immediate_analyses ((last_usage Unknown)))))))))))))) diff --git a/compiler/test/__snapshots__/pattern_matching.2cd894dc.0.snapshot b/compiler/test/__snapshots__/pattern_matching.2cd894dc.0.snapshot new file mode 100644 index 0000000000..037cf239e4 --- /dev/null +++ b/compiler/test/__snapshots__/pattern_matching.2cd894dc.0.snapshot @@ -0,0 +1,67 @@ +pattern matching › box_record_match +((mash_code + ((functions ()) (imports ()) (exports ()) + (main_body + (((instr_desc + (MStore + (((MLocalBind 0 GrainValue) + ((instr_desc + (MAllocate + (MBox + ((immediate_desc (MImmConst (MConstSimpleNumber 1))) + (immediate_analyses ((last_usage Unknown))))))))))))) + ((instr_desc + (MStore + (((MLocalBind 1 GrainValue) + ((instr_desc + (MRecordOp (MRecordGet 0) + ((immediate_desc (MImmBinding (MLocalBind 0 GrainValue))) + (immediate_analyses ((last_usage Unknown)))))))))))) + ((instr_desc + (MStore + (((MLocalBind 2 GrainValue) + ((instr_desc + (MPrim2 Eq + ((immediate_desc (MImmBinding (MLocalBind 1 GrainValue))) + (immediate_analyses ((last_usage Unknown)))) + ((immediate_desc (MImmConst (MConstSimpleNumber 1))) + (immediate_analyses ((last_usage Unknown)))))))))))) + ((instr_desc + (MStore + (((MLocalBind 3 GrainValue) + ((instr_desc + (MIf + ((immediate_desc (MImmBinding (MLocalBind 2 GrainValue))) + (immediate_analyses ((last_usage Unknown)))) + (((instr_desc + (MImmediate + ((immediate_desc (MImmConst (MConstSimpleNumber 0))) + (immediate_analyses ((last_usage Unknown)))))))) + (((instr_desc + (MImmediate + ((immediate_desc (MImmConst (MConstSimpleNumber 1))) + (immediate_analyses ((last_usage Unknown)))))))))))))))) + ((instr_desc + (MSwitch + ((immediate_desc (MImmBinding (MLocalBind 3 GrainValue))) + (immediate_analyses ((last_usage Unknown)))) + ((0 + (((instr_desc + (MImmediate + ((immediate_desc (MImmConst MConstTrue)) + (immediate_analyses ((last_usage Unknown))))))))) + (1 + (((instr_desc + (MImmediate + ((immediate_desc (MImmConst MConstFalse)) + (immediate_analyses ((last_usage Unknown)))))))))) + (((instr_desc + (MImmediate + ((immediate_desc MImmTrap) + (immediate_analyses ((last_usage Unknown)))))))) + GrainValue))))) + (main_body_stack_size + ((stack_size_ref 4) (stack_size_i32 0) (stack_size_i64 0) + (stack_size_f32 0) (stack_size_f64 0))) + (globals ()) (compilation_mode Normal) (type_metadata ))) + (signature )) diff --git a/compiler/test/suites/boxes.re b/compiler/test/suites/boxes.re index ae5793bb9b..0d55b9fce0 100644 --- a/compiler/test/suites/boxes.re +++ b/compiler/test/suites/boxes.re @@ -35,6 +35,7 @@ describe("boxes", ({test, testSkip}) => { "let b = box(4);\n {\n b := unbox(b) - 1;\n print(unbox(b))\n }", "3\n", ); + assertRun("raw_box", "print({ _value: 2 } == box(2))", "true\n"); assertSnapshot("test_set_extra1", "box(1) := 2"); assertFileRun("counter-box", "counter-box", "1\n2\n3\n"); assertCompileError("test_unbox_err", "unbox(5)", "Box"); diff --git a/compiler/test/suites/pattern_matching.re b/compiler/test/suites/pattern_matching.re index 7b97c597ee..939771d6d9 100644 --- a/compiler/test/suites/pattern_matching.re +++ b/compiler/test/suites/pattern_matching.re @@ -102,6 +102,10 @@ describe("pattern matching", ({test, testSkip}) => { |}, Warnings.PartialMatch("({b: {a: 0}, c: 0}|{b: {a: 1}, _ })"), ); + assertSnapshot( + "box_record_match", + "match(box(1)) { { _value: 1 } => true, _ => false}", + ); /* Pattern matching on ADTs */ assertSnapshot( "adt_match_1", diff --git a/stdlib/runtime/string.gr b/stdlib/runtime/string.gr index 94d12d52ad..f2a67117f5 100644 --- a/stdlib/runtime/string.gr +++ b/stdlib/runtime/string.gr @@ -86,6 +86,8 @@ let _OPTION_ID = builtinId("Option") let _RESULT_ID = builtinId("Result") @unsafe let _RANGE_ID = builtinId("Range") +@unsafe +let _BOX_ID = builtinId("Box") let _SOME = "Some" let _NONE = "None" @@ -161,6 +163,12 @@ let isRangeRecord = record_ => { typeId is _RANGE_ID } +@unsafe +let isBoxRecord = record_ => { + let typeId = DataStructures.loadRecordTypeId(record_) + typeId is _BOX_ID +} + @unsafe let getBuiltinVariantName = variant => { let typeId = DataStructures.loadVariantTypeId(variant) @@ -551,6 +559,22 @@ let rec heapValueToString = (ref, extraIndents, toplevel, cycles) => { }, } }, + t when t == Tags._GRAIN_RECORD_HEAP_TAG && isBoxRecord(ref) => { + if (loadCycleMarker(ref) != 0n) { + reportCycle(ref, cycles) + } else { + storeCycleMarker(ref, _VISITED_BIT) + let recordValues = getCompoundValueArrayRef(ref) + let fieldValue = toStringHelp( + WasmArrayRef.getAny(recordValues, 0n), + 0n, + false, + cycles + ) + storeCycleMarker(ref, 0n) + join([cyclePrefix(ref, cycles), "box(", fieldValue, ")"]) + } + }, t when t == Tags._GRAIN_RECORD_HEAP_TAG => { let recordArity = WasmArrayRef.length(getCompoundValueArrayRef(ref)) let fields = getRecordFieldNames(ref) @@ -669,11 +693,6 @@ let rec heapValueToString = (ref, extraIndents, toplevel, cycles) => { storeCycleMarker(ref, 0n) strings = [lparen, ...strings] - if (tupleLength <= 1n) { - // Special case: unary tuple, which is not valid Grain syntax; however, boxed values - // are stored as a unary tuple, so we keep this in case one gets printed - strings = ["box", ...strings] - } join([cyclePrefix(ref, cycles), ...strings]) } },