diff --git a/src/as_values/prim.ml b/src/as_values/prim.ml index 92e0bcba75f..1adc64a5ba5 100644 --- a/src/as_values/prim.ml +++ b/src/as_values/prim.ml @@ -253,8 +253,6 @@ let prim = function let nobbles = mapi (fun i f -> f i) (classify_utf8_leader (of_int (Char.code s.[0]))) in let code = fold_left (fun acc nobble -> logor (shift_left acc 6) nobble) 0l nobbles in k (Tup [Word32 (of_int (length nobbles)); Char (to_int code)]) - | "@serialize" -> fun v k -> k (Serialized v) - | "@deserialize" -> fun v k -> k (as_serialized v) | "array_len" -> fun v k -> k (Int (Int.of_int (Array.length (Value.as_array v)))) diff --git a/src/codegen/compile.ml b/src/codegen/compile.ml index 443a0f1be6a..b3857d4dad5 100644 --- a/src/codegen/compile.ml +++ b/src/codegen/compile.ml @@ -5058,258 +5058,284 @@ and compile_exp (env : E.t) ae exp = SR.UnboxedReference, compile_exp_as env ae SR.UnboxedReference e ^^ actor_fake_object_idx env name - (* We only allow prims of certain shapes, as they occur in the prelude *) - | CallE (_, ({ it = PrimE p; _} as pe), typ_args, e) -> - begin - (* First check for all unary prims. *) - match p with - | "array_len" -> - SR.Vanilla, - compile_exp_vanilla env ae e ^^ - Heap.load_field Arr.len_field ^^ - BigNum.from_word32 env - - | "text_len" -> - SR.Vanilla, - compile_exp_vanilla env ae e ^^ - Text.len env - - | "text_chars" -> - SR.Vanilla, - compile_exp_vanilla env ae e ^^ - Text.text_chars_direct env - - | "@serialize" -> - SR.UnboxedReference, - let t = match typ_args with [t] -> t | _ -> assert false in - compile_exp_vanilla env ae e ^^ - Serialization.serialize env t - - | "@deserialize" -> - SR.Vanilla, - let t = match typ_args with [t] -> t | _ -> assert false in - compile_exp_as env ae SR.UnboxedReference e ^^ - Serialization.deserialize env t - - | "abs" -> - SR.Vanilla, - compile_exp_vanilla env ae e ^^ - BigNum.compile_abs env - - | "rts_version" -> - SR.Vanilla, - compile_exp_as env ae SR.unit e ^^ - E.call_import env "rts" "version" - - | "idlHash" -> - SR.Vanilla, - E.trap_with env "idlHash only implemented in interpreter " - - | "Nat->Word8" - | "Int->Word8" -> - SR.Vanilla, - compile_exp_vanilla env ae e ^^ - Prim.prim_shiftToWordN env (UnboxedSmallWord.shift_of_type Type.Word8) - - | "Nat->Word16" - | "Int->Word16" -> - SR.Vanilla, - compile_exp_vanilla env ae e ^^ - Prim.prim_shiftToWordN env (UnboxedSmallWord.shift_of_type Type.Word16) - - | "Nat->Word32" - | "Int->Word32" -> - SR.UnboxedWord32, - compile_exp_vanilla env ae e ^^ - Prim.prim_intToWord32 env - - | "Nat->Word64" - | "Int->Word64" -> - SR.UnboxedWord64, - compile_exp_vanilla env ae e ^^ - BigNum.to_word64 env - - | "Nat64->Word64" - | "Int64->Word64" - | "Word64->Nat64" - | "Word64->Int64" - | "Nat32->Word32" - | "Int32->Word32" - | "Word32->Nat32" - | "Word32->Int32" - | "Nat16->Word16" - | "Int16->Word16" - | "Word16->Nat16" - | "Word16->Int16" - | "Nat8->Word8" - | "Int8->Word8" - | "Word8->Nat8" - | "Word8->Int8" -> - SR.Vanilla, - compile_exp_vanilla env ae e ^^ - G.nop - - | "Int->Int64" -> - SR.UnboxedWord64, - compile_exp_vanilla env ae e ^^ - Func.share_code1 env "Int->Int64" ("n", I32Type) [I64Type] (fun env get_n -> - get_n ^^ - BigNum.fits_signed_bits env 64 ^^ - E.else_trap_with env "losing precision" ^^ - get_n ^^ - BigNum.truncate_to_word64 env) - - | "Int->Int32" - | "Int->Int16" - | "Int->Int8" -> - let ty = exp.note.note_typ in - StackRep.of_type ty, - let pty = prim_of_typ ty in - compile_exp_vanilla env ae e ^^ - Func.share_code1 env (UnboxedSmallWord.name_of_type pty "Int->") ("n", I32Type) [I32Type] (fun env get_n -> - get_n ^^ - BigNum.fits_signed_bits env (UnboxedSmallWord.bits_of_type pty) ^^ - E.else_trap_with env "losing precision" ^^ - get_n ^^ - BigNum.truncate_to_word32 env ^^ - UnboxedSmallWord.msb_adjust pty) - - | "Nat->Nat64" -> - SR.UnboxedWord64, - compile_exp_vanilla env ae e ^^ - Func.share_code1 env "Nat->Nat64" ("n", I32Type) [I64Type] (fun env get_n -> - get_n ^^ - BigNum.fits_unsigned_bits env 64 ^^ - E.else_trap_with env "losing precision" ^^ - get_n ^^ - BigNum.truncate_to_word64 env) - - | "Nat->Nat32" - | "Nat->Nat16" - | "Nat->Nat8" -> - let ty = exp.note.note_typ in - StackRep.of_type ty, - let pty = prim_of_typ ty in - compile_exp_vanilla env ae e ^^ - Func.share_code1 env (UnboxedSmallWord.name_of_type pty "Nat->") ("n", I32Type) [I32Type] (fun env get_n -> - get_n ^^ - BigNum.fits_unsigned_bits env (UnboxedSmallWord.bits_of_type pty) ^^ - E.else_trap_with env "losing precision" ^^ - get_n ^^ - BigNum.truncate_to_word32 env ^^ - UnboxedSmallWord.msb_adjust pty) - - | "Char->Word32" -> - SR.UnboxedWord32, - compile_exp_vanilla env ae e ^^ - UnboxedSmallWord.unbox_codepoint - - | "Nat8->Nat" - | "Word8->Nat" -> - SR.Vanilla, - compile_exp_vanilla env ae e ^^ - Prim.prim_shiftWordNtoUnsigned env (UnboxedSmallWord.shift_of_type Type.Word8) - | "Int8->Int" - | "Word8->Int" -> - SR.Vanilla, - compile_exp_vanilla env ae e ^^ - Prim.prim_shiftWordNtoSigned env (UnboxedSmallWord.shift_of_type Type.Word8) - - | "Nat16->Nat" - | "Word16->Nat" -> - SR.Vanilla, - compile_exp_vanilla env ae e ^^ - Prim.prim_shiftWordNtoUnsigned env (UnboxedSmallWord.shift_of_type Type.Word16) - | "Int16->Int" - | "Word16->Int" -> - SR.Vanilla, - compile_exp_vanilla env ae e ^^ - Prim.prim_shiftWordNtoSigned env (UnboxedSmallWord.shift_of_type Type.Word16) - - | "Nat32->Nat" - | "Word32->Nat" -> - SR.Vanilla, - compile_exp_as env ae SR.UnboxedWord32 e ^^ - Prim.prim_word32toNat env - | "Int32->Int" - | "Word32->Int" -> - SR.Vanilla, - compile_exp_as env ae SR.UnboxedWord32 e ^^ - Prim.prim_word32toInt env - - | "Nat64->Nat" - | "Word64->Nat" -> - SR.Vanilla, - compile_exp_as env ae SR.UnboxedWord64 e ^^ - BigNum.from_word64 env - | "Int64->Int" - | "Word64->Int" -> - SR.Vanilla, - compile_exp_as env ae SR.UnboxedWord64 e ^^ - BigNum.from_signed_word64 env - - | "Word32->Char" -> - SR.Vanilla, - compile_exp_as env ae SR.UnboxedWord32 e ^^ - UnboxedSmallWord.box_codepoint - - | "popcnt" -> - SR.UnboxedWord32, - compile_exp_as env ae SR.UnboxedWord32 e ^^ - G.i (Unary (Wasm.Values.I32 I32Op.Popcnt)) - | "popcnt8" - | "popcnt16" -> - SR.Vanilla, - compile_exp_vanilla env ae e ^^ - G.i (Unary (Wasm.Values.I32 I32Op.Popcnt)) ^^ - UnboxedSmallWord.msb_adjust (match p with | "popcnt8" -> Type.Word8 | _ -> Type.Word16) - | "popcnt64" -> - SR.UnboxedWord64, - compile_exp_as env ae SR.UnboxedWord64 e ^^ - G.i (Unary (Wasm.Values.I64 I64Op.Popcnt)) - | "clz" -> SR.UnboxedWord32, compile_exp_as env ae SR.UnboxedWord32 e ^^ G.i (Unary (Wasm.Values.I32 I32Op.Clz)) - | "clz8" -> SR.Vanilla, compile_exp_vanilla env ae e ^^ UnboxedSmallWord.clz_kernel Type.Word8 - | "clz16" -> SR.Vanilla, compile_exp_vanilla env ae e ^^ UnboxedSmallWord.clz_kernel Type.Word16 - | "clz64" -> SR.UnboxedWord64, compile_exp_as env ae SR.UnboxedWord64 e ^^ G.i (Unary (Wasm.Values.I64 I64Op.Clz)) - | "ctz" -> SR.UnboxedWord32, compile_exp_as env ae SR.UnboxedWord32 e ^^ G.i (Unary (Wasm.Values.I32 I32Op.Ctz)) - | "ctz8" -> SR.Vanilla, compile_exp_vanilla env ae e ^^ UnboxedSmallWord.ctz_kernel Type.Word8 - | "ctz16" -> SR.Vanilla, compile_exp_vanilla env ae e ^^ UnboxedSmallWord.ctz_kernel Type.Word16 - | "ctz64" -> SR.UnboxedWord64, compile_exp_as env ae SR.UnboxedWord64 e ^^ G.i (Unary (Wasm.Values.I64 I64Op.Ctz)) - - | "Char->Text" -> - SR.Vanilla, - compile_exp_vanilla env ae e ^^ - Text.prim_showChar env - - | "print" -> - SR.unit, - compile_exp_vanilla env ae e ^^ - Dfinity.prim_print env - | "decodeUTF8" -> - SR.UnboxedTuple 2, - compile_exp_vanilla env ae e ^^ - Text.prim_decodeUTF8 env - | _ -> - (* Now try the binary prims, expecting a manifest tuple argument *) - begin match e.it with - | TupE [e1;e2] -> - begin - let compile_kernel_as sr inst = sr, compile_exp_as env ae sr e1 ^^ compile_exp_as env ae sr e2 ^^ inst - in match p with - | "Array.init" -> compile_kernel_as SR.Vanilla (Arr.init env) - | "Array.tabulate" -> compile_kernel_as SR.Vanilla (Arr.tabulate env) - | "btst8" -> compile_kernel_as SR.Vanilla (UnboxedSmallWord.btst_kernel env Type.Word8) - | "btst16" -> compile_kernel_as SR.Vanilla (UnboxedSmallWord.btst_kernel env Type.Word16) - | "btst" -> compile_kernel_as SR.UnboxedWord32 (UnboxedSmallWord.btst_kernel env Type.Word32) - | "btst64" -> compile_kernel_as SR.UnboxedWord64 ( - let (set_b, get_b) = new_local64 env "b" - in set_b ^^ compile_const_64 1L ^^ get_b ^^ G.i (Binary (Wasm.Values.I64 I64Op.Shl)) ^^ - G.i (Binary (Wasm.Values.I64 I64Op.And))) - - | _ -> SR.Unreachable, todo_trap env "compile_exp" (Arrange_ir.exp pe) - end - | _ -> SR.Unreachable, todo_trap env "compile_exp" (Arrange_ir.exp pe) - end + | PrimE (p, es) -> + + (* for more concise code when all arguments and result use the same sr *) + let const_sr sr inst = sr, G.concat_map (compile_exp_as env ae sr) es ^^ inst in + + begin match p, es with + + (* Operators *) + + | UnPrim (_, Operator.PosOp), [e1] -> compile_exp env ae e1 + | UnPrim (t, op), [e1] -> + let sr_in, sr_out, code = compile_unop env t op in + sr_out, + compile_exp_as env ae sr_in e1 ^^ + code + | BinPrim (t, op), [e1;e2] -> + let sr_in, sr_out, code = compile_binop env t op in + sr_out, + compile_exp_as env ae sr_in e1 ^^ + compile_exp_as env ae sr_in e2 ^^ + code + | RelPrim (t, op), [e1;e2] -> + let sr, code = compile_relop env t op in + SR.bool, + compile_exp_as env ae sr e1 ^^ + compile_exp_as env ae sr e2 ^^ + code + + (* Special prims *) + + | SerializePrim t, [e] -> + SR.UnboxedReference, + compile_exp_vanilla env ae e ^^ + Serialization.serialize env t + + | DeserializePrim t, [e] -> + SR.Vanilla, + compile_exp_as env ae SR.UnboxedReference e ^^ + Serialization.deserialize env t + + (* Other prims, unary*) + + | OtherPrim "array_len", [e] -> + SR.Vanilla, + compile_exp_vanilla env ae e ^^ + Heap.load_field Arr.len_field ^^ + BigNum.from_word32 env + + | OtherPrim "text_len", [e] -> + SR.Vanilla, + compile_exp_vanilla env ae e ^^ + Text.len env + + | OtherPrim "text_chars", [e] -> + SR.Vanilla, + compile_exp_vanilla env ae e ^^ + Text.text_chars_direct env + + | OtherPrim "abs", [e] -> + SR.Vanilla, + compile_exp_vanilla env ae e ^^ + BigNum.compile_abs env + + | OtherPrim "rts_version", [] -> + SR.Vanilla, + E.call_import env "rts" "version" + + | OtherPrim "idlHash", [e] -> + SR.Vanilla, + E.trap_with env "idlHash only implemented in interpreter " + + | OtherPrim "Nat->Word8", [e] + | OtherPrim "Int->Word8", [e] -> + SR.Vanilla, + compile_exp_vanilla env ae e ^^ + Prim.prim_shiftToWordN env (UnboxedSmallWord.shift_of_type Type.Word8) + + | OtherPrim "Nat->Word16", [e] + | OtherPrim "Int->Word16", [e] -> + SR.Vanilla, + compile_exp_vanilla env ae e ^^ + Prim.prim_shiftToWordN env (UnboxedSmallWord.shift_of_type Type.Word16) + + | OtherPrim "Nat->Word32", [e] + | OtherPrim "Int->Word32", [e] -> + SR.UnboxedWord32, + compile_exp_vanilla env ae e ^^ + Prim.prim_intToWord32 env + + | OtherPrim "Nat->Word64", [e] + | OtherPrim "Int->Word64", [e] -> + SR.UnboxedWord64, + compile_exp_vanilla env ae e ^^ + BigNum.to_word64 env + + | OtherPrim "Nat64->Word64", [e] + | OtherPrim "Int64->Word64", [e] + | OtherPrim "Word64->Nat64", [e] + | OtherPrim "Word64->Int64", [e] + | OtherPrim "Nat32->Word32", [e] + | OtherPrim "Int32->Word32", [e] + | OtherPrim "Word32->Nat32", [e] + | OtherPrim "Word32->Int32", [e] + | OtherPrim "Nat16->Word16", [e] + | OtherPrim "Int16->Word16", [e] + | OtherPrim "Word16->Nat16", [e] + | OtherPrim "Word16->Int16", [e] + | OtherPrim "Nat8->Word8", [e] + | OtherPrim "Int8->Word8", [e] + | OtherPrim "Word8->Nat8", [e] + | OtherPrim "Word8->Int8", [e] -> + SR.Vanilla, + compile_exp_vanilla env ae e ^^ + G.nop + + | OtherPrim "Int->Int64", [e] -> + SR.UnboxedWord64, + compile_exp_vanilla env ae e ^^ + Func.share_code1 env "Int->Int64" ("n", I32Type) [I64Type] (fun env get_n -> + get_n ^^ + BigNum.fits_signed_bits env 64 ^^ + E.else_trap_with env "losing precision" ^^ + get_n ^^ + BigNum.truncate_to_word64 env) + + | OtherPrim "Int->Int32", [e] + | OtherPrim "Int->Int16", [e] + | OtherPrim "Int->Int8", [e] -> + let ty = exp.note.note_typ in + StackRep.of_type ty, + let pty = prim_of_typ ty in + compile_exp_vanilla env ae e ^^ + Func.share_code1 env (UnboxedSmallWord.name_of_type pty "Int->") ("n", I32Type) [I32Type] (fun env get_n -> + get_n ^^ + BigNum.fits_signed_bits env (UnboxedSmallWord.bits_of_type pty) ^^ + E.else_trap_with env "losing precision" ^^ + get_n ^^ + BigNum.truncate_to_word32 env ^^ + UnboxedSmallWord.msb_adjust pty) + + | OtherPrim "Nat->Nat64", [e] -> + SR.UnboxedWord64, + compile_exp_vanilla env ae e ^^ + Func.share_code1 env "Nat->Nat64" ("n", I32Type) [I64Type] (fun env get_n -> + get_n ^^ + BigNum.fits_unsigned_bits env 64 ^^ + E.else_trap_with env "losing precision" ^^ + get_n ^^ + BigNum.truncate_to_word64 env) + + | OtherPrim "Nat->Nat32", [e] + | OtherPrim "Nat->Nat16", [e] + | OtherPrim "Nat->Nat8", [e] -> + let ty = exp.note.note_typ in + StackRep.of_type ty, + let pty = prim_of_typ ty in + compile_exp_vanilla env ae e ^^ + Func.share_code1 env (UnboxedSmallWord.name_of_type pty "Nat->") ("n", I32Type) [I32Type] (fun env get_n -> + get_n ^^ + BigNum.fits_unsigned_bits env (UnboxedSmallWord.bits_of_type pty) ^^ + E.else_trap_with env "losing precision" ^^ + get_n ^^ + BigNum.truncate_to_word32 env ^^ + UnboxedSmallWord.msb_adjust pty) + + | OtherPrim "Char->Word32", [e] -> + SR.UnboxedWord32, + compile_exp_vanilla env ae e ^^ + UnboxedSmallWord.unbox_codepoint + + | OtherPrim "Nat8->Nat", [e] + | OtherPrim "Word8->Nat", [e] -> + SR.Vanilla, + compile_exp_vanilla env ae e ^^ + Prim.prim_shiftWordNtoUnsigned env (UnboxedSmallWord.shift_of_type Type.Word8) + | OtherPrim "Int8->Int", [e] + | OtherPrim "Word8->Int", [e] -> + SR.Vanilla, + compile_exp_vanilla env ae e ^^ + Prim.prim_shiftWordNtoSigned env (UnboxedSmallWord.shift_of_type Type.Word8) + + | OtherPrim "Nat16->Nat", [e] + | OtherPrim "Word16->Nat", [e] -> + SR.Vanilla, + compile_exp_vanilla env ae e ^^ + Prim.prim_shiftWordNtoUnsigned env (UnboxedSmallWord.shift_of_type Type.Word16) + | OtherPrim "Int16->Int", [e] + | OtherPrim "Word16->Int", [e] -> + SR.Vanilla, + compile_exp_vanilla env ae e ^^ + Prim.prim_shiftWordNtoSigned env (UnboxedSmallWord.shift_of_type Type.Word16) + + | OtherPrim "Nat32->Nat", [e] + | OtherPrim "Word32->Nat", [e] -> + SR.Vanilla, + compile_exp_as env ae SR.UnboxedWord32 e ^^ + Prim.prim_word32toNat env + | OtherPrim "Int32->Int", [e] + | OtherPrim "Word32->Int", [e] -> + SR.Vanilla, + compile_exp_as env ae SR.UnboxedWord32 e ^^ + Prim.prim_word32toInt env + + | OtherPrim "Nat64->Nat", [e] + | OtherPrim "Word64->Nat", [e] -> + SR.Vanilla, + compile_exp_as env ae SR.UnboxedWord64 e ^^ + BigNum.from_word64 env + | OtherPrim "Int64->Int", [e] + | OtherPrim "Word64->Int", [e] -> + SR.Vanilla, + compile_exp_as env ae SR.UnboxedWord64 e ^^ + BigNum.from_signed_word64 env + + | OtherPrim "Word32->Char", [e] -> + SR.Vanilla, + compile_exp_as env ae SR.UnboxedWord32 e ^^ + UnboxedSmallWord.box_codepoint + + | OtherPrim "popcnt", [e] -> + SR.UnboxedWord32, + compile_exp_as env ae SR.UnboxedWord32 e ^^ + G.i (Unary (Wasm.Values.I32 I32Op.Popcnt)) + | OtherPrim "popcnt8", [e] -> + SR.Vanilla, + compile_exp_vanilla env ae e ^^ + G.i (Unary (Wasm.Values.I32 I32Op.Popcnt)) ^^ + UnboxedSmallWord.msb_adjust Type.Word8 + | OtherPrim "popcnt16", [e] -> + SR.Vanilla, + compile_exp_vanilla env ae e ^^ + G.i (Unary (Wasm.Values.I32 I32Op.Popcnt)) ^^ + UnboxedSmallWord.msb_adjust Type.Word16 + | OtherPrim "popcnt64", [e] -> + SR.UnboxedWord64, + compile_exp_as env ae SR.UnboxedWord64 e ^^ + G.i (Unary (Wasm.Values.I64 I64Op.Popcnt)) + | OtherPrim "clz", [e] -> SR.UnboxedWord32, compile_exp_as env ae SR.UnboxedWord32 e ^^ G.i (Unary (Wasm.Values.I32 I32Op.Clz)) + | OtherPrim "clz8", [e] -> SR.Vanilla, compile_exp_vanilla env ae e ^^ UnboxedSmallWord.clz_kernel Type.Word8 + | OtherPrim "clz16", [e] -> SR.Vanilla, compile_exp_vanilla env ae e ^^ UnboxedSmallWord.clz_kernel Type.Word16 + | OtherPrim "clz64", [e] -> SR.UnboxedWord64, compile_exp_as env ae SR.UnboxedWord64 e ^^ G.i (Unary (Wasm.Values.I64 I64Op.Clz)) + | OtherPrim "ctz", [e] -> SR.UnboxedWord32, compile_exp_as env ae SR.UnboxedWord32 e ^^ G.i (Unary (Wasm.Values.I32 I32Op.Ctz)) + | OtherPrim "ctz8", [e] -> SR.Vanilla, compile_exp_vanilla env ae e ^^ UnboxedSmallWord.ctz_kernel Type.Word8 + | OtherPrim "ctz16", [e] -> SR.Vanilla, compile_exp_vanilla env ae e ^^ UnboxedSmallWord.ctz_kernel Type.Word16 + | OtherPrim "ctz64", [e] -> SR.UnboxedWord64, compile_exp_as env ae SR.UnboxedWord64 e ^^ G.i (Unary (Wasm.Values.I64 I64Op.Ctz)) + + | OtherPrim "Char->Text", [e] -> + SR.Vanilla, + compile_exp_vanilla env ae e ^^ + Text.prim_showChar env + + | OtherPrim "print", [e] -> + SR.unit, + compile_exp_vanilla env ae e ^^ + Dfinity.prim_print env + | OtherPrim "decodeUTF8", [e] -> + SR.UnboxedTuple 2, + compile_exp_vanilla env ae e ^^ + Text.prim_decodeUTF8 env + + (* Other prims, binary*) + | OtherPrim "Array.init", [_;_] -> + const_sr SR.Vanilla (Arr.init env) + | OtherPrim "Array.tabulate", [_;_] -> + const_sr SR.Vanilla (Arr.tabulate env) + | OtherPrim "btst8", [_;_] -> + const_sr SR.Vanilla (UnboxedSmallWord.btst_kernel env Type.Word8) + | OtherPrim "btst16", [_;_] -> + const_sr SR.Vanilla (UnboxedSmallWord.btst_kernel env Type.Word16) + | OtherPrim "btst", [_;_] -> + const_sr SR.UnboxedWord32 (UnboxedSmallWord.btst_kernel env Type.Word32) + | OtherPrim "btst64", [_;_] -> + const_sr SR.UnboxedWord64 ( + let (set_b, get_b) = new_local64 env "b" in + set_b ^^ compile_const_64 1L ^^ get_b ^^ G.i (Binary (Wasm.Values.I64 I64Op.Shl)) ^^ + G.i (Binary (Wasm.Values.I64 I64Op.And)) + ) + | _ -> SR.Unreachable, todo_trap env "compile_exp" (Arrange_ir.exp exp) end | VarE var -> Var.get_val env ae var @@ -5325,24 +5351,6 @@ and compile_exp (env : E.t) ae exp = SR.unit, compile_exp_as env ae SR.bool e1 ^^ G.if_ (ValBlockType None) G.nop (G.i Unreachable) - | UnE (_, Operator.PosOp, e1) -> compile_exp env ae e1 - | UnE (t, op, e1) -> - let sr_in, sr_out, code = compile_unop env t op in - sr_out, - compile_exp_as env ae sr_in e1 ^^ - code - | BinE (t, e1, op, e2) -> - let sr_in, sr_out, code = compile_binop env t op in - sr_out, - compile_exp_as env ae sr_in e1 ^^ - compile_exp_as env ae sr_in e2 ^^ - code - | RelE (t, e1, op, e2) -> - let sr, code = compile_relop env t op in - SR.bool, - compile_exp_as env ae sr e1 ^^ - compile_exp_as env ae sr e2 ^^ - code | IfE (scrut, e1, e2) -> let code_scrut = compile_exp_as env ae SR.bool scrut in let sr1, code1 = compile_exp env ae e1 in diff --git a/src/ir_def/arrange_ir.ml b/src/ir_def/arrange_ir.ml index 49e9b52a743..41da72302d7 100644 --- a/src/ir_def/arrange_ir.ml +++ b/src/ir_def/arrange_ir.ml @@ -14,10 +14,7 @@ let kind k = Atom (Type.string_of_kind k) let rec exp e = match e.it with | VarE i -> "VarE" $$ [id i] | LitE l -> "LitE" $$ [lit l] - | UnE (t, uo, e) -> "UnE" $$ [typ t; Arrange_ops.unop uo; exp e] - | BinE (t, e1, bo, e2)-> "BinE" $$ [typ t; exp e1; Arrange_ops.binop bo; exp e2] - | RelE (t, e1, ro, e2)-> "RelE" $$ [typ t; exp e1; Arrange_ops.relop ro; exp e2] - | ShowE (t, e) -> "ShowE" $$ [typ t; exp e] + | PrimE (p, es) -> "PrimE" $$ [prim p] @ List.map exp es | TupE es -> "TupE" $$ List.map exp es | ProjE (e, i) -> "ProjE" $$ [exp e; Atom (string_of_int i)] | DotE (e, n) -> "DotE" $$ [exp e; Atom n] @@ -38,7 +35,6 @@ let rec exp e = match e.it with | AssertE e -> "AssertE" $$ [exp e] | OptE e -> "OptE" $$ [exp e] | TagE (i, e) -> "TagE" $$ [id i; exp e] - | PrimE p -> "PrimE" $$ [Atom p] | DeclareE (i, t, e1) -> "DeclareE" $$ [id i; exp e1] | DefineE (i, m, e1) -> "DefineE" $$ [id i; mut m; exp e1] | FuncE (x, cc, tp, as_, ts, e) -> @@ -54,6 +50,15 @@ and args = function and arg a = Atom a.it +and prim = function + | UnPrim (t, uo) -> "UnPrim" $$ [typ t; Arrange_ops.unop uo] + | BinPrim (t, bo) -> "BinPrim" $$ [typ t; Arrange_ops.binop bo] + | RelPrim (t, ro) -> "RelPrim" $$ [typ t; Arrange_ops.relop ro] + | ShowPrim t -> "ShowPrim" $$ [typ t] + | SerializePrim t -> "SerializePrim" $$ [typ t] + | DeserializePrim t -> "DeserializePrim" $$ [typ t] + | OtherPrim s -> Atom s + and mut = function | Const -> Atom "Const" | Var -> Atom "Var" diff --git a/src/ir_def/check_ir.ml b/src/ir_def/check_ir.ml index ea47c5c6777..69c3f51ba3d 100644 --- a/src/ir_def/check_ir.ml +++ b/src/ir_def/check_ir.ml @@ -189,11 +189,8 @@ let rec check_typ env typ : unit = check env no_region env.flavor.Ir.serialized "Serialized in non-serialized flavor"; check_typ env typ; - (* TODO: we cannot currently express abstract shared types, - so @serialize is a hack *) - (*check env no_region (T.shared typ) - * "serialized type is not sharable:\n %s" (T.string_of_typ_expand typ) - *) + check env no_region (T.shared typ) + "serialized type is not sharable:\n %s" (T.string_of_typ_expand typ) | T.Typ c -> check env no_region (T.ConSet.mem c env.cons) "free type constructor %s" (Con.name c); @@ -279,12 +276,10 @@ let type_lit env lit at : T.prim = let isAsyncE exp = match exp.it with - | AsyncE _ -> (* pre await transformation *) - true - | CallE(_,{it=PrimE("@async");_}, _, cps) -> (* post await transformation *) - true - | _ -> - false + | AsyncE _ (* pre await transformation *) + | PrimE(OtherPrim "@async", [_]) (* post await transformation *) + -> true + | _ -> false let rec check_exp env (exp:Ir.exp) : unit = (* helpers *) @@ -299,7 +294,6 @@ let rec check_exp env (exp:Ir.exp) : unit = "inferred effect not a subtype of expected effect"; (* check typing *) match exp.it with - | PrimE _ -> () | VarE id -> let t0 = try T.Env.find id env.vals with | Not_found -> error env exp.at "unbound variable %s" id @@ -307,31 +301,49 @@ let rec check_exp env (exp:Ir.exp) : unit = t0 <~ t | LitE lit -> T.Prim (type_lit env lit exp.at) <: t - | UnE (ot, op, exp1) -> - check (Operator.has_unop op ot) "unary operator is not defined for operand type"; - check_exp env exp1; - typ exp1 <: ot; - ot <: t - | BinE (ot, exp1, op, exp2) -> - check (Operator.has_binop op ot) "binary operator is not defined for operand type"; - check_exp env exp1; - check_exp env exp2; - typ exp1 <: ot; - typ exp2 <: ot; - ot <: t - | ShowE (ot, exp1) -> - check env.flavor.has_show "show expression in non-show flavor"; - check (Show.can_show ot) "show is not defined for operand type"; - check_exp env exp1; - typ exp1 <: ot; - T.Prim T.Text <: t - | RelE (ot, exp1, op, exp2) -> - check (Operator.has_relop op ot) "relational operator is not defined for operand type"; - check_exp env exp1; - check_exp env exp2; - typ exp1 <: ot; - typ exp2 <: ot; - T.bool <: t + | PrimE (p, es) -> + begin match p, es with + | UnPrim (ot, op), [exp1] -> + check (Operator.has_unop op ot) "unary operator is not defined for operand type"; + check_exp env exp1; + typ exp1 <: ot; + ot <: t + | BinPrim (ot, op), [exp1; exp2] -> + check (Operator.has_binop op ot) "binary operator is not defined for operand type"; + check_exp env exp1; + check_exp env exp2; + typ exp1 <: ot; + typ exp2 <: ot; + ot <: t + | RelPrim (ot, op), [exp1; exp2] -> + check (Operator.has_relop op ot) "relational operator is not defined for operand type"; + check_exp env exp1; + check_exp env exp2; + typ exp1 <: ot; + typ exp2 <: ot; + T.bool <: t + | ShowPrim ot, [exp1] -> + check env.flavor.has_show "show expression in non-show flavor"; + check (Show.can_show ot) "show is not defined for operand type"; + check_exp env exp1; + typ exp1 <: ot; + T.Prim T.Text <: t + | SerializePrim ot, [exp1] -> + check env.flavor.serialized "Serialized expression in wrong flavor"; + check (T.shared ot) "argument to SerializePrim not shared"; + check_exp env exp1; + typ exp1 <: ot; + T.Serialized ot <: t + | DeserializePrim ot, [exp1] -> + check env.flavor.serialized "Serialized expression in wrong flavor"; + check (T.shared ot) "argument to SerializePrim not shared"; + check_exp env exp1; + typ exp1 <: T.Serialized ot; + ot <: t + | OtherPrim _, _ -> () + | _ -> + error env exp.at "PrimE with wrong number of arguments" + end | TupE exps -> List.iter (check_exp env) exps; T.Tup (List.map typ exps) <: t diff --git a/src/ir_def/construct.ml b/src/ir_def/construct.ml index f2867a2bb76..b81e3a9dae5 100644 --- a/src/ir_def/construct.ml +++ b/src/ir_def/construct.ml @@ -82,12 +82,33 @@ let as_seqP p = (* Primitives *) -let primE name typ = - { it = PrimE name; +let primE prim es = + let ty = match prim with + | DeserializePrim t -> t + | SerializePrim t -> T.Serialized t + | ShowPrim _ -> T.text + | _ -> assert false (* implement more as needed *) + in + let effs = List.map eff es in + let e = List.fold_left max_eff T.Triv effs in + { it = PrimE (prim, es); at = no_region; - note = { note_typ = typ; note_eff = T.Triv } + note = { note_typ = ty; note_eff = e } + } + +let asyncE typ e = + { it = PrimE (OtherPrim "@async", [e]); + at = no_region; + note = { note_typ = T.Async typ; note_eff = eff e } + } + +let awaitE typ e1 e2 = + { it = PrimE (OtherPrim "@await", [e1; e2]); + at = no_region; + note = { note_typ = T.unit; note_eff = max_eff (eff e1) (eff e2) } } + (* tuples *) let projE e n = @@ -438,16 +459,6 @@ let ( -*- ) exp1 exp2 = (Wasm.Sexpr.to_string 80 (Arrange_ir.exp exp2))) -(* Intermediate, cps-based @async and @await primitives, - introduced by await(opt).ml, removed by async.ml -*) - -let prim_async typ = - primE "@async" (T.Func (T.Local, T.Returns, [], [cpsT typ], [T.Async typ])) - -let prim_await typ = - primE "@await" (T.Func (T.Local, T.Returns, [], [T.Async typ; contT typ], [])) - (* derived loop forms; each can be expressed as an unconditional loop *) let whileE exp1 exp2 = diff --git a/src/ir_def/construct.mli b/src/ir_def/construct.mli index ff788c746da..13c4152fe66 100644 --- a/src/ir_def/construct.mli +++ b/src/ir_def/construct.mli @@ -39,7 +39,9 @@ val as_seqP : pat -> pat list (* Expressions *) -val primE : string -> typ -> exp +val primE : Ir.prim -> exp list -> exp +val asyncE : typ -> exp -> exp +val awaitE : typ -> exp -> exp -> exp val projE : exp -> int -> exp val blockE : dec list -> exp -> exp val textE : string -> exp @@ -99,12 +101,3 @@ val (-->) : var -> exp -> exp val (-->*) : var list -> exp -> exp (* n-ary local *) val (-@>*) : var list -> exp -> exp (* n-ary shared *) val (-*-) : exp -> exp -> exp (* application *) - - -(* intermediate, cps-based @async and @await primitives, - introduced by await(opt).ml to be removed by async.ml *) - -val prim_async : typ -> exp - -val prim_await : typ -> exp - diff --git a/src/ir_def/freevars.ml b/src/ir_def/freevars.ml index fd44e06b080..a99f6ffacfd 100644 --- a/src/ir_def/freevars.ml +++ b/src/ir_def/freevars.ml @@ -59,11 +59,7 @@ let close (f,d) = diff f d let rec exp e : f = match e.it with | VarE i -> M.singleton i {captured = false} | LitE l -> M.empty - | PrimE _ -> M.empty - | UnE (_, uo, e) -> exp e - | BinE (_, e1, bo, e2) -> exps [e1; e2] - | RelE (_, e1, ro, e2) -> exps [e1; e2] - | ShowE (_, e) -> exp e + | PrimE (_, es) -> exps es | TupE es -> exps es | ProjE (e, i) -> exp e | DotE (e, i) -> exp e diff --git a/src/ir_def/ir.ml b/src/ir_def/ir.ml index 05131e9e193..a4fe9a9a911 100644 --- a/src/ir_def/ir.ml +++ b/src/ir_def/ir.ml @@ -61,13 +61,9 @@ type arg = (string, Type.typ) Source.annotated_phrase type exp = exp' phrase and exp' = - | PrimE of string (* primitive *) + | PrimE of (prim * exp list) (* primitive *) | VarE of id (* variable *) | LitE of lit (* literal *) - | UnE of Type.typ * unop * exp (* unary operator *) - | BinE of Type.typ * exp * binop * exp (* binary operator *) - | RelE of Type.typ * exp * relop * exp (* relational operator *) - | ShowE of Type.typ * exp (* debug show *) | TupE of exp list (* tuple *) | ProjE of exp * int (* tuple projection *) | OptE of exp (* option injection *) @@ -102,6 +98,14 @@ and field' = {name : Type.lab; var : id} (* the var is by reference, not by valu and case = case' Source.phrase and case' = {pat : pat; exp : exp} +and prim = + | UnPrim of Type.typ * unop (* unary operator *) + | BinPrim of Type.typ * binop (* binary operator *) + | RelPrim of Type.typ * relop (* relational operator *) + | ShowPrim of Type.typ (* debug show *) + | SerializePrim of Type.typ (* serialize *) + | DeserializePrim of Type.typ (* deserialize *) + | OtherPrim of string (* Other primitive operation, no custom typing rule *) (* Declarations *) diff --git a/src/ir_def/ir_effect.ml b/src/ir_def/ir_effect.ml index 43289ba8101..981f76fa6c1 100644 --- a/src/ir_def/ir_effect.ml +++ b/src/ir_def/ir_effect.ml @@ -25,12 +25,9 @@ let effect_exp (exp: exp) : T.eff = eff exp (* infer the effect of an expression, assuming all sub-expressions are correctly effect-annotated es*) let rec infer_effect_exp (exp: exp) : T.eff = match exp.it with - | PrimE _ | VarE _ | LitE _ -> T.Triv - | UnE (_, _, exp1) - | ShowE (_, exp1) | ProjE (exp1, _) | OptE exp1 | TagE (_, exp1) @@ -42,14 +39,13 @@ let rec infer_effect_exp (exp: exp) : T.eff = | RetE exp1 | LoopE exp1 -> effect_exp exp1 - | BinE (_, exp1, _, exp2) | IdxE (exp1, exp2) - | RelE (_, exp1, _, exp2) | AssignE (exp1, exp2) | CallE (_, exp1, _, exp2) -> let t1 = effect_exp exp1 in let t2 = effect_exp exp2 in max_eff t1 t2 + | PrimE (_, exps) | TupE exps | ArrayE (_, _, exps) -> let es = List.map effect_exp exps in diff --git a/src/ir_interpreter/interpret_ir.ml b/src/ir_interpreter/interpret_ir.ml index 230d4715aa8..487899e4059 100644 --- a/src/ir_interpreter/interpret_ir.ml +++ b/src/ir_interpreter/interpret_ir.ml @@ -288,11 +288,6 @@ and interpret_exp_mut env exp (k : V.value V.cont) = last_env := env; Profiler.bump_region exp.at ; match exp.it with - | PrimE s -> - let at = exp.at in - let t = exp.note.note_typ in - let cc = call_conv_of_typ t in - k (V.Func (cc, extended_prim env s t at)) | VarE id -> (match Lib.Promise.value_opt (find id env.vals) with | Some v -> k v @@ -300,26 +295,43 @@ and interpret_exp_mut env exp (k : V.value V.cont) = ) | LitE lit -> k (interpret_lit env lit) - | UnE (ot, op, exp1) -> - interpret_exp env exp1 (fun v1 -> k (try Operator.unop op ot v1 with Invalid_argument s -> trap exp.at "%s" s)) - | ShowE (ot, exp1) -> - interpret_exp env exp1 (fun v -> - if Show.can_show ot - then k (Value.Text (Show.show_val ot v)) - else raise (Invalid_argument "debug_show")) - | BinE (ot, exp1, op, exp2) -> - interpret_exp env exp1 (fun v1 -> - interpret_exp env exp2 (fun v2 -> - k (try Operator.binop op ot v1 v2 with _ -> - trap exp.at "arithmetic overflow") + | PrimE (p, es) -> + begin match p, es with + | UnPrim (ot, op), [exp1] -> + interpret_exp env exp1 (fun v1 -> k (try Operator.unop op ot v1 with Invalid_argument s -> trap exp.at "%s" s)) + | BinPrim (ot, op), [exp1; exp2] -> + interpret_exp env exp1 (fun v1 -> + interpret_exp env exp2 (fun v2 -> + k (try Operator.binop op ot v1 v2 with _ -> + trap exp.at "arithmetic overflow") + ) ) - ) - | RelE (ot, exp1, op, exp2) -> - interpret_exp env exp1 (fun v1 -> - interpret_exp env exp2 (fun v2 -> - k (Operator.relop op ot v1 v2) + | RelPrim (ot, op), [exp1; exp2] -> + interpret_exp env exp1 (fun v1 -> + interpret_exp env exp2 (fun v2 -> + k (Operator.relop op ot v1 v2) + ) ) - ) + | ShowPrim ot, [exp1] -> + interpret_exp env exp1 (fun v -> + if Show.can_show ot + then k (Value.Text (Show.show_val ot v)) + else raise (Invalid_argument "debug_show")) + | SerializePrim t, [exp1] -> + interpret_exp env exp1 (fun v -> k (V.Serialized v)) + | DeserializePrim t, [exp1] -> + interpret_exp env exp1 (fun v -> k (V.as_serialized v)) + | OtherPrim s, exps -> + interpret_exps env exps [] (fun vs -> + let at = exp.at in + let t = exp.note.note_typ in + let arg = match vs with [v] -> v | _ -> V.Tup vs in + extended_prim env s t at arg k + ) + | _ -> + trap exp.at "Unknown prim or wrong number of arguments (%d given):\n %s" + (List.length es) (Wasm.Sexpr.to_string 80 (Arrange_ir.prim p)) + end | TupE exps -> interpret_exps env exps [] (fun vs -> k (V.Tup vs)) | OptE exp1 -> diff --git a/src/ir_passes/async.ml b/src/ir_passes/async.ml index d0072e39ef3..a2bdc82938d 100644 --- a/src/ir_passes/async.ml +++ b/src/ir_passes/async.ml @@ -193,11 +193,14 @@ module Transform() = struct Type.set_kind clone (t_kind (Con.kind c)); clone - and t_operator_type ot = - (* We recreate the reference here. That is ok, because it - we run after type inference. Once we move async past desugaring, - it will be a pure value anyways. *) - t_typ ot + and prim = function + | UnPrim (ot, op) -> UnPrim (t_typ ot, op) + | BinPrim (ot, op) -> BinPrim (t_typ ot, op) + | RelPrim (ot, op) -> RelPrim (t_typ ot, op) + | ShowPrim ot -> ShowPrim (t_typ ot) + | SerializePrim ot -> SerializePrim (t_typ ot) + | DeserializePrim ot -> DeserializePrim (t_typ ot) + | OtherPrim s -> OtherPrim s and t_field {lab; typ} = { lab; typ = t_typ typ } @@ -211,17 +214,8 @@ module Transform() = struct and t_exp' (exp:exp) = let exp' = exp.it in match exp' with - | PrimE _ - | LitE _ -> exp' + | LitE _ -> exp' | VarE id -> exp' - | UnE (ot, op, exp1) -> - UnE (t_operator_type ot, op, t_exp exp1) - | ShowE (ot, exp1) -> - ShowE (t_operator_type ot, t_exp exp1) - | BinE (ot, exp1, op, exp2) -> - BinE (t_operator_type ot, t_exp exp1, op, t_exp exp2) - | RelE (ot, exp1, op, exp2) -> - RelE (t_operator_type ot, t_exp exp1, op, t_exp exp2) | TupE exps -> TupE (List.map t_exp exps) | OptE exp1 -> @@ -240,13 +234,9 @@ module Transform() = struct ArrayE (mut, t_typ t, List.map t_exp exps) | IdxE (exp1, exp2) -> IdxE (t_exp exp1, t_exp exp2) - | CallE (cc,{it=PrimE "@await";_}, typs, exp2) -> - begin - match exp2.it with - | TupE [a;k] -> ((t_exp a) -*- (t_exp k)).it - | _ -> assert false - end - | CallE (cc,{it=PrimE "@async";_}, typs, exp2) -> + | PrimE (OtherPrim "@await", [a;k]) -> + ((t_exp a) -*- (t_exp k)).it + | PrimE (OtherPrim "@async", [exp2]) -> let t1, contT = match typ exp2 with | Func(_,_, [], @@ -286,6 +276,8 @@ module Transform() = struct ) nary_async) .it + | PrimE (p, exps) -> + PrimE (prim p, List.map t_exp exps) | CallE (cc, exp1, typs, exp2) -> CallE(cc, t_exp exp1, List.map t_typ typs, t_exp exp2) | BlockE b -> @@ -336,12 +328,8 @@ module Transform() = struct let y = fresh_var "y" res_typ in let exp' = match exp.it with - | CallE(_, async,_,cps) -> - begin - match async.it with - | PrimE("@async") -> ((t_exp cps) -*- (y --> (k -*- y))) - | _ -> assert false - end + | PrimE (OtherPrim "@async", [cps]) -> + (t_exp cps) -*- (y --> (k -*- y)) | _ -> assert false in FuncE (x, cc', typbinds', args', [], exp') diff --git a/src/ir_passes/await.ml b/src/ir_passes/await.ml index 33e3eb54f54..d3427e74b51 100644 --- a/src/ir_passes/await.ml +++ b/src/ir_passes/await.ml @@ -61,17 +61,10 @@ let rec t_exp context exp = { exp with it = t_exp' context exp.it } and t_exp' context exp' = match exp' with - | PrimE _ | VarE _ | LitE _ -> exp' - | UnE (ot, op, exp1) -> - UnE (ot, op, t_exp context exp1) - | BinE (ot, exp1, op, exp2) -> - BinE (ot, t_exp context exp1, op, t_exp context exp2) - | RelE (ot, exp1, op, exp2) -> - RelE (ot, t_exp context exp1, op, t_exp context exp2) - | ShowE (ot, exp1) -> - ShowE (ot, t_exp context exp1) + | PrimE (p, exps) -> + PrimE (p, List.map (t_exp context) exps) | TupE exps -> TupE (List.map (t_exp context) exps) | OptE exp1 -> @@ -127,8 +120,7 @@ and t_exp' context exp' = (* add the implicit return label *) let k_ret = fresh_cont (typ exp1) in let context' = LabelEnv.add id_ret (Cont (ContVar k_ret)) LabelEnv.empty in - (prim_async (typ exp1) -*- (k_ret --> (c_exp context' exp1 (ContVar k_ret)))) - .it + (asyncE (typ exp1) (k_ret --> (c_exp context' exp1 (ContVar k_ret)))).it | AwaitE _ -> assert false (* an await never has effect T.Triv *) | AssertE exp1 -> AssertE (t_exp context exp1) @@ -235,19 +227,12 @@ and c_exp' context exp k = match exp.it with | _ when is_triv exp -> k -@- (t_exp context exp) - | PrimE _ | VarE _ | LitE _ | FuncE _ -> assert false - | UnE (ot, op, exp1) -> - unary context k (fun v1 -> e (UnE (ot, op, v1))) exp1 - | BinE (ot, exp1, op, exp2) -> - binary context k (fun v1 v2 -> e (BinE (ot, v1, op, v2))) exp1 exp2 - | RelE (ot, exp1, op, exp2) -> - binary context k (fun v1 v2 -> e (RelE (ot, v1, op, v2))) exp1 exp2 - | ShowE (ot, exp1) -> - unary context k (fun v1 -> e (ShowE (ot, v1))) exp1 + | PrimE (p, exps) -> + nary context k (fun vs -> e (PrimE (p, vs))) exps | TupE exps -> nary context k (fun vs -> e (TupE vs)) exps | OptE exp1 -> @@ -321,16 +306,16 @@ and c_exp' context exp k = (* add the implicit return label *) let k_ret = fresh_cont (typ exp1) in let context' = LabelEnv.add id_ret (Cont (ContVar k_ret)) LabelEnv.empty in - k -@- (prim_async (typ exp1) -*- (k_ret --> (c_exp context' exp1 (ContVar k_ret)))) + k -@- (asyncE (typ exp1) (k_ret --> (c_exp context' exp1 (ContVar k_ret)))) | AwaitE exp1 -> letcont k (fun k -> match eff exp1 with | T.Triv -> - prim_await (typ exp) -*- (tupE [t_exp context exp1;k]) + awaitE (typ exp) (t_exp context exp1) k | T.Await -> c_exp context exp1 - (meta (typ exp1) (fun v1 -> (prim_await (typ exp) -*- (tupE [v1;k])))) + (meta (typ exp1) (fun v1 -> (awaitE (typ exp) v1 k))) ) | AssertE exp1 -> unary context k (fun v1 -> e (AssertE v1)) exp1 diff --git a/src/ir_passes/rename.ml b/src/ir_passes/rename.ml index ed77b58f224..7e0f41192f1 100644 --- a/src/ir_passes/rename.ml +++ b/src/ir_passes/rename.ml @@ -33,11 +33,7 @@ let rec exp rho e = and exp' rho e = match e with | VarE i -> VarE (id rho i) | LitE l -> e - | PrimE _ -> e - | UnE (ot, uo, e) -> UnE (ot, uo, exp rho e) - | BinE (ot, e1, bo, e2)-> BinE (ot, exp rho e1, bo, exp rho e2) - | RelE (ot, e1, ro, e2)-> RelE (ot, exp rho e1, ro, exp rho e2) - | ShowE (ot, e) -> ShowE (ot, exp rho e) + | PrimE (p, es) -> PrimE (p, List.map (exp rho) es) | TupE es -> TupE (List.map (exp rho) es) | ProjE (e, i) -> ProjE (exp rho e, i) | ActorE (i, ds, fs, t)-> let i',rho' = id_bind rho i in diff --git a/src/ir_passes/serialization.ml b/src/ir_passes/serialization.ml index 52811aa5b2d..6846e4a3e5a 100644 --- a/src/ir_passes/serialization.ml +++ b/src/ir_passes/serialization.ml @@ -31,23 +31,12 @@ module Transform() = struct let con_renaming = ref ConRenaming.empty (* The primitive serialization functions *) - let deserialize_prim = - let open Type in - let var : var = "A" in - primE "@deserialize" - (Func (Local, Returns, [{var; bound = Any}], [Serialized (Var (var, 0))], [(Var (var, 0))])) - let serialize_prim = - let open Type in - let var : var = "A" in - primE "@serialize" - (Func (Local, Returns, [{var; bound = Any}], [Var (var, 0)], [Serialized (Var (var, 0))])) - let deserialize e = let t = T.as_serialized e.note.note_typ in - callE deserialize_prim [t] e + primE (DeserializePrim t) [e] let serialize e t = - callE serialize_prim [t] e + primE (SerializePrim t) [e] let serialized_arg a = { it = a.it ^ "/raw"; note = T.Serialized a.note; at = a.at } @@ -155,17 +144,10 @@ module Transform() = struct (t_exp exp) in FuncE (x, cc, [], raw_args, [], body') end - | PrimE _ | LitE _ -> exp' | VarE id -> exp' - | UnE (ot, op, exp1) -> - UnE (t_typ ot, op, t_exp exp1) - | BinE (ot, exp1, op, exp2) -> - BinE (t_typ ot, t_exp exp1, op, t_exp exp2) - | RelE (ot, exp1, op, exp2) -> - RelE (t_typ ot, t_exp exp1, op, t_exp exp2) - | ShowE (ot, exp1) -> - ShowE (t_typ ot, t_exp exp1) + | PrimE (p, exps) -> + PrimE (p, List.map t_exp exps) | TupE exps -> TupE (List.map t_exp exps) | OptE exp1 -> diff --git a/src/ir_passes/show.ml b/src/ir_passes/show.ml index 6ce4b8efb53..3376239cf33 100644 --- a/src/ir_passes/show.ml +++ b/src/ir_passes/show.ml @@ -64,20 +64,14 @@ and t_exp env (e : Ir.exp) = { e with it = t_exp' env e.it } and t_exp' env = function - | PrimE p -> PrimE p | LitE l -> LitE l | VarE id -> VarE id - | ShowE (ot, exp1) -> + | PrimE (ShowPrim ot, [exp1]) -> let t' = T.normalize ot in add_type env t'; let f = idE (show_name_for t') (show_fun_typ_for t') in CallE (Call_conv.local_cc 1 1, f, [], t_exp env exp1) - | UnE (ot, op, exp1) -> - UnE (ot, op, t_exp env exp1) - | BinE (ot, exp1, op, exp2) -> - BinE (ot, t_exp env exp1, op, t_exp env exp2) - | RelE (ot, exp1, op, exp2) -> - RelE (ot, t_exp env exp1, op, t_exp env exp2) + | PrimE (p, es) -> PrimE (p, t_exps env es) | TupE exps -> TupE (t_exps env exps) | OptE exp1 -> OptE (t_exp env exp1) @@ -253,7 +247,7 @@ let list_build : 'a -> 'a -> 'a -> 'a list -> 'a list = fun pre sep post xs -> in [ pre ] @ go xs let catE : Ir.exp -> Ir.exp -> Ir.exp = fun e1 e2 -> - { it = BinE (T.Prim T.Text, e1, Operator.CatOp, e2) + { it = PrimE (BinPrim (T.text, Operator.CatOp), [e1; e2]) ; at = no_region ; note = { note_typ = T.Prim T.Text; note_eff = T.Triv } } diff --git a/src/ir_passes/tailcall.ml b/src/ir_passes/tailcall.ml index d775af681b4..e28953fbc77 100644 --- a/src/ir_passes/tailcall.ml +++ b/src/ir_passes/tailcall.ml @@ -92,13 +92,8 @@ and assignEs vars exp : dec list = List.mapi (fun i v -> expD (assignE v (projE v i))) vars and exp' env e : exp' = match e.it with - | VarE _ - | LitE _ - | PrimE _ -> e.it - | UnE (ot, uo, e) -> UnE (ot, uo, exp env e) - | BinE (ot, e1, bo, e2)-> BinE (ot, exp env e1, bo, exp env e2) - | RelE (ot, e1, ro, e2)-> RelE (ot, exp env e1, ro, exp env e2) - | ShowE (ot, e) -> ShowE (ot, exp env e) + | VarE _ | LitE _ -> e.it + | PrimE (p, es) -> PrimE (p, List.map (exp env) es) | TupE es -> TupE (List.map (exp env) es) | ProjE (e, i) -> ProjE (exp env e, i) | DotE (e, sn) -> DotE (exp env e, sn) diff --git a/src/lowering/desugar.ml b/src/lowering/desugar.ml index 9c9be101aa9..4c385454538 100644 --- a/src/lowering/desugar.ml +++ b/src/lowering/desugar.ml @@ -56,17 +56,16 @@ and exp e = | _ -> typed_phrase' exp' e and exp' at note = function - | S.PrimE p -> I.PrimE p | S.VarE i -> I.VarE i.it | S.LitE l -> I.LitE (lit !l) | S.UnE (ot, o, e) -> - I.UnE (!ot, o, exp e) + I.PrimE (I.UnPrim (!ot, o), [exp e]) | S.BinE (ot, e1, o, e2) -> - I.BinE (!ot, exp e1, o, exp e2) + I.PrimE (I.BinPrim (!ot, o), [exp e1; exp e2]) | S.RelE (ot, e1, o, e2) -> - I.RelE (!ot, exp e1, o, exp e2) + I.PrimE (I.RelPrim (!ot, o), [exp e1; exp e2]) | S.ShowE (ot, e) -> - I.ShowE (!ot, exp e) + I.PrimE (I.ShowPrim !ot, [exp e]) | S.TupE es -> I.TupE (exps es) | S.ProjE (e, i) -> I.ProjE (exp e, i) | S.OptE e -> I.OptE (exp e) @@ -96,6 +95,11 @@ and exp' at note = function let ty = T.open_ vars ty in let tys = if cc.Call_conv.n_res = 1 then [ty] else T.as_seq ty in I.FuncE (name, cc, tbs', args, tys, wrap (exp e)) + (* Primitive functions in the prelude have particular shapes *) + | S.CallE ({it=S.AnnotE ({it=S.PrimE p;_},_);_}, _, {it=S.TupE es;_}) -> + I.PrimE (I.OtherPrim p, exps es) + | S.CallE ({it=S.AnnotE ({it=S.PrimE p;_},_);_}, _, e) -> + I.PrimE (I.OtherPrim p, [exp e]) | S.CallE (e1, inst, e2) -> let t = e1.Source.note.S.note_typ in if T.is_non t @@ -126,6 +130,7 @@ and exp' at note = function | S.ImportE (f, fp) -> if !fp = "" then assert false; (* unresolved import *) I.VarE (id_of_full_path !fp).it + | S.PrimE s -> raise (Invalid_argument ("Unapplied prim " ^ s)) and mut m = match m.it with | S.Const -> Ir.Const diff --git a/test/fail/ok/use-before-define5.wasm.stderr.ok b/test/fail/ok/use-before-define5.wasm.stderr.ok index ae7d5dd979a..338435413bd 100644 --- a/test/fail/ok/use-before-define5.wasm.stderr.ok +++ b/test/fail/ok/use-before-define5.wasm.stderr.ok @@ -6,7 +6,7 @@ non-closed actor: (ActorE foo (shared 0 -> 0) () - (AssertE (RelE Nat (VarE x) EqOp (LitE (NatLit 1)))) + (AssertE (PrimE (RelPrim Nat EqOp) (VarE x) (LitE (NatLit 1)))) ) ) (foo foo) diff --git a/test/run-dfinity/ok/counter-class.wasm.stderr.ok b/test/run-dfinity/ok/counter-class.wasm.stderr.ok index 2677c7e0195..c2f74b31a4d 100644 --- a/test/run-dfinity/ok/counter-class.wasm.stderr.ok +++ b/test/run-dfinity/ok/counter-class.wasm.stderr.ok @@ -9,7 +9,10 @@ non-closed actor: (ActorE () (BlockE (LetD WildP (CallE (1 -> 0) (VarE showCounter) (VarE j))) - (AssignE (VarE j) (BinE Int (VarE j) SubOp (LitE (IntLit 1)))) + (AssignE + (VarE j) + (PrimE (BinPrim Int SubOp) (VarE j) (LitE (IntLit 1))) + ) ) ) ) @@ -24,10 +27,8 @@ non-closed actor: (ActorE (LetD (TupP (VarP $k/0)) (TupE - (CallE - (1 -> 1) - (PrimE @deserialize) - shared (serialized Int) -> () + (PrimE + (DeserializePrim shared (serialized Int) -> ()) (VarE $k/0/raw) ) ) @@ -49,7 +50,7 @@ non-closed actor: (ActorE (CallE (shared 1 -> 0) (VarE $k/0) - (CallE (1 -> 1) (PrimE @serialize) Int (VarE $y/0)) + (PrimE (SerializePrim Int) (VarE $y/0)) ) ) )