feat: add prim call_raw : (Principal, Text, Blob) -> async Blob

src/codegen/compile.ml

@@ -6362,8 +6362,22 @@ module FuncDec = struct
      deserialization); the reject callback function is unique.
   *)
 
-  let closures_to_reply_reject_callbacks env ts =
-    let reply_name = "@callback<" ^ Typ_hash.typ_hash (Type.Tup ts) ^ ">" in
+  let closures_to_reply_reject_callbacks_aux env ts_opt =
+    let arity, reply_name, from_arg_data =
+      match ts_opt with
+      | Some ts ->
+        (List.length ts,
+         "@callback<" ^ Typ_hash.typ_hash (Type.Tup ts) ^ ">",
+         fun env -> Serialization.deserialize env ts)
+      | None ->
+        (1,
+         "@callback",
+         (fun env ->
+           Blob.of_size_copy env
+           (fun env -> IC.system_call env "ic0" "msg_arg_data_size")
+           (fun env -> IC.system_call env "ic0" "msg_arg_data_copy")
+           (fun env -> compile_unboxed_const 0l)))
+    in
     Func.define_built_in env reply_name ["env", I32Type] [] (fun env ->
         message_start env (Type.Shared Type.Write) ^^
         (* Look up continuation *)
@@ -6374,11 +6388,11 @@ module FuncDec = struct
         set_closure ^^
         get_closure ^^
 
-        (* Deserialize reply arguments  *)
-        Serialization.deserialize env ts ^^
+        (* Deserialize/Blobify reply arguments  *)
+        from_arg_data env ^^
 
         get_closure ^^
-        Closure.call_closure env (List.length ts) 0 ^^
+        Closure.call_closure env arity 0 ^^
 
         message_cleanup env (Type.Shared Type.Write)
       );
@@ -6418,6 +6432,11 @@ module FuncDec = struct
       compile_unboxed_const (E.add_fun_ptr env (E.built_in env reject_name)) ^^
       get_cb_index
 
+  let closures_to_reply_reject_callbacks env ts =
+    closures_to_reply_reject_callbacks_aux env (Some ts)
+  let closures_to_raw_reply_reject_callbacks env  =
+    closures_to_reply_reject_callbacks_aux env None
+
   let ignoring_callback env =
     (* for one-way calls, we use an invalid table entry as the callback. this
        way, the callback, when it comes back, will (safely) trap, even if the
@@ -6470,6 +6489,14 @@ module FuncDec = struct
       (closures_to_reply_reject_callbacks env ts2 [get_k; get_r])
       (fun _ -> get_arg ^^ Serialization.serialize env ts1)
 
+  let ic_call_raw env get_meth_pair get_arg get_k get_r =
+    ic_call_threaded
+      env
+      "raw call"
+      get_meth_pair
+      (closures_to_raw_reply_reject_callbacks env [get_k; get_r])
+      (fun _ -> get_arg ^^ Blob.as_ptr_len env)
+
   let ic_self_call env ts get_meth_pair get_future get_k get_r =
     ic_call_threaded
       env
@@ -8234,7 +8261,21 @@ and compile_exp (env : E.t) ae exp =
       compile_exp_vanilla env ae r ^^ set_r ^^
       FuncDec.ic_call env ts1 ts2 get_meth_pair get_arg get_k get_r add_cycles
       end
-
+    | ICCallRawPrim, [p;m;a;k;r] ->
+      SR.unit, begin
+      let (set_meth_pair, get_meth_pair) = new_local env "meth_pair" in
+      let (set_arg, get_arg) = new_local env "arg" in
+      let (set_k, get_k) = new_local env "k" in
+      let (set_r, get_r) = new_local env "r" in
+      let add_cycles = Internals.add_cycles env ae in
+      compile_exp_vanilla env ae p ^^
+      compile_exp_vanilla env ae m ^^
+      Tuple.from_stack env 2 ^^ set_meth_pair ^^
+      compile_exp_vanilla env ae a ^^ set_arg ^^
+      compile_exp_vanilla env ae k ^^ set_k ^^
+      compile_exp_vanilla env ae r ^^ set_r ^^
+      FuncDec.ic_call_raw env get_meth_pair get_arg get_k get_r add_cycles
+      end
     | ICStableRead ty, [] ->
       (*
         * On initial install:

src/ir_def/arrange_ir.ml

@@ -98,6 +98,7 @@ and prim = function
   | ICRejectPrim      -> Atom "ICRejectPrim"
   | ICCallerPrim      -> Atom "ICCallerPrim"
   | ICCallPrim        -> Atom "ICCallPrim"
+  | ICCallRawPrim     -> Atom "ICCallRawPrim"
   | ICStableWrite t   -> "ICStableWrite" $$ [typ t]
   | ICStableRead t    -> "ICStableRead" $$ [typ t]
 

src/ir_def/check_ir.ml

@@ -593,6 +593,14 @@ let rec check_exp env (exp:Ir.exp) : unit =
          error env exp1.at "expected function type, but expression produces type\n  %s"
            (T.string_of_typ_expand t1)
       end
+      (* TODO: T.unit <: t ? *)
+    | ICCallRawPrim, [exp1; exp2; exp3; k; r] ->
+      typ exp1 <: T.principal;
+      typ exp2 <: T.text;
+      typ exp3 <: T.blob;
+      typ k <: T.Func (T.Local, T.Returns, [], [T.blob], []);
+      typ r <: T.Func (T.Local, T.Returns, [], [T.error], []);
+      T.unit <: t
     | ICStableRead t1, [] ->
       check_typ env t1;
       check (store_typ t1) "Invalid type argument to ICStableRead";

src/ir_def/construct.ml

@@ -176,6 +176,14 @@ let ic_callE f e k r =
     note = Note.{ def with typ = T.unit; eff = eff }
   }
 
+let ic_call_rawE p m a k r =
+  let es = [p; m; a; k; r] in
+  let effs = List.map eff es in
+  let eff = List.fold_left max_eff T.Triv effs in
+  { it = PrimE (ICCallRawPrim, es);
+    at = no_region;
+    note = Note.{ def with typ = T.unit; eff = eff }
+  }
 
 (* tuples *)
 

src/ir_def/construct.mli

@@ -56,6 +56,7 @@ val cps_awaitE : typ -> exp -> exp -> exp
 val ic_replyE : typ list -> exp -> exp
 val ic_rejectE : exp -> exp
 val ic_callE : exp -> exp -> exp -> exp -> exp
+val ic_call_rawE : exp -> exp -> exp -> exp -> exp -> exp
 val projE : exp -> int -> exp
 val optE : exp -> exp
 val tagE : id -> exp -> exp

src/ir_def/ir.ml

@@ -162,6 +162,7 @@ and prim =
   | ICRejectPrim
   | ICCallerPrim
   | ICCallPrim
+  | ICCallRawPrim
   | ICStableWrite of Type.typ          (* serialize value of stable type to stable memory *)
   | ICStableRead of Type.typ           (* deserialize value of stable type from stable memory *)
 
@@ -294,7 +295,8 @@ let map_prim t_typ t_id p =
   | ICReplyPrim ts -> ICReplyPrim (List.map t_typ ts)
   | ICRejectPrim
   | ICCallerPrim
-  | ICCallPrim -> p
+  | ICCallPrim
+  | ICCallRawPrim -> p
   | ICStableWrite t -> ICStableWrite (t_typ t)
   | ICStableRead t -> ICStableRead (t_typ t)
 

src/ir_passes/async.ml

@@ -287,6 +287,23 @@ let transform mode prog =
          )
          (varE nary_async))
         .it
+    | PrimE (OtherPrim "call_raw", [exp1; exp2; exp3]) ->
+      let exp1' = t_exp exp1 in
+      let exp2' = t_exp exp2 in
+      let exp3' = t_exp exp3 in
+      let ((nary_async, nary_reply, reject), def) = new_nary_async_reply mode [T.blob] in
+      let _ = letEta in
+      (blockE (
+        letP (tupP [varP nary_async; varP nary_reply; varP reject]) def ::
+          letEta exp1' (fun v1 ->
+          letEta exp2' (fun v2 ->
+          letEta exp3' (fun v3 ->
+            [ expD (ic_call_rawE v1 v2 v3 (varE nary_reply) (varE reject)) ]
+            )
+          ))
+         )
+         (varE nary_async))
+        .it
     | PrimE (p, exps) ->
       PrimE (t_prim p, List.map t_exp exps)
     | BlockE b ->

src/prelude/prim.mo

@@ -357,3 +357,8 @@ func stableMemoryLoadBlob(offset : Nat64, size : Nat) : Blob =
 
 func stableMemoryStoreBlob(offset : Nat64, val :  Blob) : () =
   (prim "stableMemoryStoreBlob" : (Nat64, Blob) -> ()) (offset, val);
+
+// raw calls
+func call_raw(p : Principal, m : Text, a : Blob) : async Blob {
+  await (prim "call_raw" : (Principal, Text, Blob) -> async Blob) (p, m, a);
+};

test/run-drun/call-raw.mo

@@ -0,0 +1,99 @@
+import P "mo:⛔";
+
+actor self {
+
+
+  public shared func sint() : async Int {
+    return 2;
+  };
+
+  public shared func snat() : async Nat {
+    return 2;
+  };
+
+  public shared func stext() : async Text {
+    return "hello";
+  };
+
+  public shared func stuple() : async (Nat, Bool, Char) {
+    return (1, true, 'a');
+  };
+
+  public shared func unit() : async () {
+    P.debugPrint("unit!");
+  };
+
+  public shared func int(n : Int) : async Int {
+    P.debugPrint(debug_show("int",n));
+    return n;
+  };
+
+  public shared func text(t : Text) : async Text {
+    P.debugPrint(debug_show("text", t));
+    return t;
+  };
+
+  public shared func tuple(n: Nat, b: Bool, c: Char) : async (Nat, Bool, Char) {
+    P.debugPrint(debug_show("text", (n, b, c)));
+    return (n, b, c);
+  };
+
+  public shared func trapInt(n : Int) : async Int {
+    P.trap("ohoh");
+  };
+
+  public shared func go() : async () {
+    let p = P.principalOfActor(self);
+
+    do {
+      let arg : Blob = "DIDL\00\00";
+      let res = await P.call_raw(p,"unit", arg);
+      assert (res == arg);
+    };
+
+    do {
+      let arg : Blob = "DIDL\00\01\7c\01";
+      let res = await P.call_raw(p,"int", arg);
+      assert (res == arg);
+     };
+
+    do {
+      let arg : Blob = "DIDL\00\01\7c\02";
+      let res = await P.call_raw(p,"int", arg);
+      assert (res == arg);
+    };
+
+    do {
+      let arg : Blob = "DIDL\00\01\71\05\68\65\6c\6c\6f";
+      let res = await P.call_raw(p,"text", arg);
+      assert (res == arg);
+    };
+
+    do {
+      let arg : Blob = "DIDL\00\03\7d\7e\79\01\01\61\00\00\00";
+      let res = await P.call_raw(p,"tuple", arg);
+      assert (res == arg);
+    };
+
+    do {
+      let arg : Blob = "DIDL\00\01\7c\01";
+      try {
+        let res = await P.call_raw(p,"trapInt", arg);
+        assert false;
+      }
+      catch e {
+        P.debugPrint(P.errorMessage(e));
+      }
+    };
+  }
+};
+
+//SKIP run
+//SKIP run-low
+//SKIP run-ir
+//CALL ingress sint 0x4449444C0000
+//CALL ingress snat 0x4449444C0000
+//CALL ingress stext 0x4449444C0000
+//CALL ingress stuple 0x4449444C0000
+//CALL ingress go 0x4449444C0000
+

test/run-drun/ok/call-raw.drun-run.ok

@@ -0,0 +1,13 @@
+ingress Completed: Reply: 0x4449444c016c01b3c4b1f204680100010a00000000000000000101
+ingress Completed: Reply: 0x4449444c0000
+ingress Completed: Reply: 0x4449444c00017c02
+ingress Completed: Reply: 0x4449444c00017d02
+ingress Completed: Reply: 0x4449444c0001710568656c6c6f
+ingress Completed: Reply: 0x4449444c00037d7e79010161000000
+debug.print: unit!
+debug.print: ("int", +1)
+debug.print: ("int", +2)
+debug.print: ("text", "hello")
+debug.print: ("text", (1, true, 'a'))
+debug.print: IC0503: Canister rwlgt-iiaaa-aaaaa-aaaaa-cai trapped explicitly: ohoh
+ingress Completed: Reply: 0x4449444c0000

test/run-drun/ok/call-raw.ic-ref-run.ok

@@ -0,0 +1,20 @@
+→ update create_canister(record {settings = null})
+← replied: (record {hymijyo = principal "cvccv-qqaaq-aaaaa-aaaaa-c"})
+→ update install_code(record {arg = blob ""; kca_xin = blob "\00asm\01\00\00\00\0…
+← replied: ()
+→ update sint()
+← replied: (+2)
+→ update snat()
+← replied: (2)
+→ update stext()
+← replied: ("hello")
+→ update stuple()
+← replied: (1, true, (97 : nat32))
+→ update go()
+debug.print: unit!
+debug.print: ("int", +1)
+debug.print: ("int", +2)
+debug.print: ("text", "hello")
+debug.print: ("text", (1, true, 'a'))
+debug.print: canister trapped: EvalTrapError region:0xXXX-0xXXX "canister trapped explicitly: ohoh"
+← replied: ()