feat: parenthetical syntax for cycles etc.

doc/md/examples/grammar.txt

@@ -214,6 +214,7 @@
     'break' <id> <exp_nullary>?
     'continue' <id>
     'debug' <exp_nest>
+    '(' <exp_post>? 'with' <list(<exp_field>, ';')> ')' <exp_nest>
     'if' <exp_nullary> <exp_nest>
     'if' <exp_nullary> <exp_nest> 'else' <exp_nest>
     'try' <exp_nest> <catch>

src/codegen/compile_classical.ml

@@ -2022,7 +2022,7 @@ module Tagged = struct
     | T (* (T,+) *)
     | S (* shared ... -> ... *)
   type blob_sort =
-    |  B (* Blob *)
+    | B (* Blob *)
     | T (* Text *)
     | P (* Principal *)
     | A (* actor { ... } *)
@@ -2251,6 +2251,15 @@ module Tagged = struct
     set_tag ^^
     go cases
 
+  (* like branch_default_with but the tag is known statically *)
+  let branch_with env retty = function
+    | [] -> G.i Unreachable
+    | [_, code] -> code
+    | (_, code) :: cases ->
+       let (set_o, get_o) = new_local env "o" in
+       let prep (t, code) = (t, get_o ^^ code)
+       in set_o ^^ get_o ^^ branch_default env retty (get_o ^^ code) (List.map prep cases)
+
   let allocation_barrier env =
     (if !Flags.gc_strategy = Flags.Incremental then
       E.call_import env "rts" "allocation_barrier"
@@ -2412,12 +2421,13 @@ module Opt = struct
             ( get_x ) (* true literal, no wrapping *)
             ( get_x ^^ Tagged.branch_default env [I32Type]
               ( get_x ) (* default tag, no wrapping *)
-              [ Tagged.Null,
+              Tagged.
+              [ Null,
                 (* NB: even ?null does not require allocation: We use a static
                   singleton for that: *)
                 compile_unboxed_const (vanilla_lit env (null_vanilla_lit env))
-              ; Tagged.Some,
-                Tagged.obj env Tagged.Some [get_x]
+              ; Some,
+                obj env Some [get_x]
               ]
             )
         )
@@ -2541,7 +2551,7 @@ module Closure = struct
       I32Type :: Lib.List.make n_args I32Type,
       FakeMultiVal.ty (Lib.List.make n_res I32Type))) in
     (* get the table index *)
-    Tagged.load_forwarding_pointer env ^^
+    (*Tagged.load_forwarding_pointer env ^^ FIXME: NOT needed, accessing immut slots*)
     Tagged.load_field env (funptr_field env) ^^
     (* All done: Call! *)
     G.i (CallIndirect (nr ty)) ^^
@@ -9385,16 +9395,21 @@ end (* Var *)
    that requires top-level cps conversion;
    use new prims instead *)
 module Internals = struct
-  let call_prelude_function env ae var =
+  let call_prelude_function_with_args env ae var args =
     match VarEnv.lookup_var ae var with
     | Some (VarEnv.Const (_, Const.Fun (mk_fi, _))) ->
        compile_unboxed_zero ^^ (* A dummy closure *)
+       args ^^
        G.i (Call (nr (mk_fi ())))
     | _ -> assert false
 
+  let call_prelude_function env ae var =
+    call_prelude_function_with_args env ae var G.nop
+
   let add_cycles env ae = call_prelude_function env ae "@add_cycles"
   let reset_cycles env ae = call_prelude_function env ae "@reset_cycles"
   let reset_refund env ae = call_prelude_function env ae "@reset_refund"
+  let pass_cycles env ae = call_prelude_function_with_args env ae "@pass_cycles"
 end
 
 (* This comes late because it also deals with messages *)
@@ -10862,7 +10877,7 @@ and compile_prim_invocation (env : E.t) ae p es at =
 
   begin match p, es with
   (* Calls *)
-  | CallPrim _, [e1; e2] ->
+  | CallPrim (_, par), [e1; e2] ->
     let sort, control, _, arg_tys, ret_tys = Type.(as_func (promote e1.note.Note.typ)) in
     let n_args = List.length arg_tys in
     let return_arity = match control with
@@ -10876,8 +10891,7 @@ and compile_prim_invocation (env : E.t) ae p es at =
     let call_as_prim = match fun_sr, sort with
       | SR.Const (_, Const.Fun (mk_fi, Const.PrimWrapper prim)), _ ->
          begin match n_args, e2.it with
-         | 0, _ -> true
-         | 1, _ -> true
+         | (0 | 1), _ -> true
          | n, PrimE (TupPrim, es) when List.length es = n -> true
          | _, _ -> false
          end
@@ -10908,7 +10922,9 @@ and compile_prim_invocation (env : E.t) ae p es at =
          StackRep.of_arity return_arity,
 
          code1 ^^
-         compile_unboxed_zero ^^ (* A dummy closure *)
+         Type.(match as_obj par.note.Note.typ with
+         | Object, [] -> compile_unboxed_zero (* a dummy closure *)
+         |  _ -> compile_exp_vanilla env ae par) ^^ (* parenthetical *)
          compile_exp_as env ae (StackRep.of_arity n_args) e2 ^^ (* the args *)
          G.i (Call (nr (mk_fi ()))) ^^
          FakeMultiVal.load env (Lib.List.make return_arity I32Type)
@@ -10917,9 +10933,12 @@ and compile_prim_invocation (env : E.t) ae p es at =
 
          StackRep.of_arity return_arity,
          code1 ^^ StackRep.adjust env fun_sr SR.Vanilla ^^
+         Closure.prepare_closure_call env ^^ (* FIXME: move to front elsewhere too *)
          set_clos ^^
-         get_clos ^^
-         Closure.prepare_closure_call env ^^
+         Type.(match as_obj par.note.Note.typ, ret_tys with
+         | (Object, []), _ -> get_clos (* just the closure *)
+         |  _, [ret] when is_async_fut ret -> Arr.lit env Tagged.T [compile_exp_vanilla env ae par; get_clos] (* parenthetical: pass a pair *)
+         | _ -> get_clos) ^^ (* just the closure *)
          compile_exp_as env ae (StackRep.of_arity n_args) e2 ^^
          get_clos ^^
          Closure.call_closure env n_args return_arity
@@ -12104,7 +12123,7 @@ and compile_prim_invocation (env : E.t) ae p es at =
   | ICCallerPrim, [] ->
     SR.Vanilla, IC.caller env
 
-  | ICCallPrim, [f;e;k;r;c] ->
+  | ICCallPrim setup, [f;e;k;r;c] ->
     SR.unit, begin
     (* TBR: Can we do better than using the notes? *)
     let _, _, _, ts1, _ = Type.as_func f.note.Note.typ in
@@ -12114,7 +12133,9 @@ and compile_prim_invocation (env : E.t) ae p es at =
     let (set_k, get_k) = new_local env "k" in
     let (set_r, get_r) = new_local env "r" in
     let (set_c, get_c) = new_local env "c" in
-    let add_cycles = Internals.add_cycles env ae in
+    let add_cycles = match setup with
+      | None -> Internals.add_cycles env ae
+      | Some exp -> compile_exp_vanilla env ae exp ^^ G.i Drop in
     compile_exp_vanilla env ae f ^^ set_meth_pair ^^
     compile_exp_vanilla env ae e ^^ set_arg ^^
     compile_exp_vanilla env ae k ^^ set_k ^^
@@ -12174,6 +12195,26 @@ and compile_prim_invocation (env : E.t) ae p es at =
     SR.Vanilla, Cycles.available env
   | SystemCyclesRefundedPrim, [] ->
     SR.Vanilla, Cycles.refunded env
+  | ICCyclesPrim, [] ->
+    SR.Vanilla,
+    G.i (LocalGet (nr 0l)) ^^ (* closed-over bindings *)
+    G.if1 I32Type
+      begin
+        G.i (LocalGet (nr 0l)) ^^
+        Tagged.branch_with env [I32Type]
+          [ Tagged.Closure,
+            G.i Drop ^^
+            Opt.null_lit env
+          ; Tagged.(Array T),
+            Opt.inject_simple env (Arr.load_field env 0l) ^^
+            G.i (LocalGet (nr 0l)) ^^
+            Arr.load_field env 1l ^^
+            G.i (LocalSet (nr 0l))
+          ; Tagged.Object,
+            Opt.inject_simple env G.nop
+          ]
+      end
+      (Opt.null_lit env)
   | SystemCyclesBurnPrim, [e1] ->
     SR.Vanilla, compile_exp_vanilla env ae e1 ^^ Cycles.burn env
 
@@ -12349,15 +12390,19 @@ and compile_exp_with_hint (env : E.t) ae sr_hint exp =
     let return_arity = List.length return_tys in
     let mk_body env1 ae1 = compile_exp_as env1 ae1 (StackRep.of_arity return_arity) e in
     FuncDec.lit env ae x sort control captured args mk_body return_tys exp.at
-  | SelfCallE (ts, exp_f, exp_k, exp_r, exp_c) ->
+  | SelfCallE (cyc, ts, exp_f, exp_k, exp_r, exp_c) ->
     SR.unit,
     let (set_future, get_future) = new_local env "future" in
     let (set_k, get_k) = new_local env "k" in
     let (set_r, get_r) = new_local env "r" in
     let (set_c, get_c) = new_local env "c" in
     let mk_body env1 ae1 = compile_exp_as env1 ae1 SR.unit exp_f in
     let captured = Freevars.captured exp_f in
-    let add_cycles = Internals.add_cycles env ae in
+    let add_cycles = match cyc.it with
+      | LitE NullLit -> Internals.add_cycles env ae (* legacy *)
+      | _ when Type.(sub cyc.note.Note.typ (Opt (Obj (Object, [{ lab = "cycles"; typ = nat; src = empty_src}])))) ->
+        Internals.pass_cycles env ae (compile_exp_vanilla env ae cyc)
+      | _ -> Internals.pass_cycles env ae (Opt.null_lit env) in
     FuncDec.async_body env ae ts captured mk_body exp.at ^^
     Tagged.load_forwarding_pointer env ^^
     set_future ^^

src/codegen/compile_enhanced.ml

@@ -12199,7 +12199,7 @@ and compile_prim_invocation (env : E.t) ae p es at =
   | ICCallerPrim, [] ->
     SR.Vanilla, IC.caller env
 
-  | ICCallPrim, [f;e;k;r;c] ->
+  | ICCallPrim _FIXME, [f;e;k;r;c] ->
     SR.unit, begin
     (* TBR: Can we do better than using the notes? *)
     let _, _, _, ts1, _ = Type.as_func f.note.Note.typ in
@@ -12432,7 +12432,7 @@ and compile_exp_with_hint (env : E.t) ae sr_hint exp =
     let return_arity = List.length return_tys in
     let mk_body env1 ae1 = compile_exp_as env1 ae1 (StackRep.of_arity return_arity) e in
     FuncDec.lit env ae x sort control captured args mk_body return_tys exp.at
-  | SelfCallE (ts, exp_f, exp_k, exp_r, exp_c) ->
+  | SelfCallE (cyc_FIXME, ts, exp_f, exp_k, exp_r, exp_c) ->
     SR.unit,
     let (set_future, get_future) = new_local env "future" in
     let (set_k, get_k) = new_local env "k" in

src/ir_def/arrange_ir.ml

@@ -22,14 +22,14 @@ let rec exp e = match e.it with
   | SwitchE (e, cs)     -> "SwitchE" $$ [exp e] @ List.map case cs
   | LoopE e1            -> "LoopE"   $$ [exp e1]
   | LabelE (i, t, e)    -> "LabelE"  $$ [id i; typ t; exp e]
-  | AsyncE (Type.Fut, tb, e, t) -> "AsyncE"  $$ [typ_bind tb; exp e; typ t]
-  | AsyncE (Type.Cmp, tb, e, t) -> "AsyncE*"  $$ [typ_bind tb; exp e; typ t]
+  | AsyncE (par, Type.Fut, tb, e, t) -> "AsyncE"  $$ Option.(map exp par |> to_list) @ [typ_bind tb; exp e; typ t]
+  | AsyncE (_, Type.Cmp, tb, e, t) -> "AsyncE*"  $$ [typ_bind tb; exp e; typ t]
   | DeclareE (i, t, e1) -> "DeclareE" $$ [id i; exp e1]
   | DefineE (i, m, e1)  -> "DefineE" $$ [id i; mut m; exp e1]
   | FuncE (x, s, c, tp, as_, ts, e) ->
     "FuncE" $$ [Atom x; func_sort s; control c] @ List.map typ_bind tp @ args as_ @ [ typ (Type.seq ts); exp e]
-  | SelfCallE (ts, exp_f, exp_k, exp_r, exp_c) ->
-    "SelfCallE" $$ [typ (Type.seq ts); exp exp_f; exp exp_k; exp exp_r; exp exp_c]
+  | SelfCallE (_FIXME, ts, exp_f, exp_k, exp_r, exp_c) ->
+    "SelfCallE" $$ [exp _FIXME; typ (Type.seq ts); exp exp_f; exp exp_k; exp exp_r; exp exp_c]
   | ActorE (ds, fs, u, t) -> "ActorE"  $$ List.map dec ds @ fields fs @ [system u; typ t]
   | NewObjE (s, fs, t)  -> "NewObjE" $$ (Arrange_type.obj_sort s :: fields fs @ [typ t])
   | TryE (e, cs, None) -> "TryE" $$ [exp e] @ List.map case cs
@@ -60,7 +60,7 @@ and args = function
 and arg a = Atom a.it
 
 and prim = function
-  | CallPrim ts       -> "CallPrim" $$ List.map typ ts
+  | CallPrim (ts, _FIXME) -> "CallPrim" $$ List.map typ ts @ [exp _FIXME]
   | 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]
@@ -94,28 +94,29 @@ and prim = function
   | ActorOfIdBlob t   -> "ActorOfIdBlob" $$ [typ t]
   | BlobOfIcUrl       -> Atom "BlobOfIcUrl"
   | IcUrlOfBlob       -> Atom "IcUrlOfBlob"
-  | SelfRef t         -> "SelfRef"    $$ [typ t]
+  | SelfRef t         -> "SelfRef" $$ [typ t]
   | SystemTimePrim    -> Atom "SystemTimePrim"
   | SystemCyclesAddPrim -> Atom "SystemCyclesAddPrim"
   | SystemCyclesAcceptPrim -> Atom "SystemCyclesAcceptPrim"
   | SystemCyclesAvailablePrim -> Atom "SystemCyclesAvailablePrim"
   | SystemCyclesBalancePrim -> Atom "SystemCyclesBalancePrim"
   | SystemCyclesRefundedPrim -> Atom "SystemCyclesRefundedPrim"
+  | ICCyclesPrim      -> Atom "ICCyclesPrim"
   | SystemCyclesBurnPrim -> Atom "SystemCyclesBurnPrim"
   | SetCertifiedData  -> Atom "SetCertifiedData"
   | GetCertificate    -> Atom "GetCertificate"
   | OtherPrim s       -> Atom s
   | CPSAwait (Type.Fut, t) -> "CPSAwait" $$ [typ t]
   | CPSAwait (Type.Cmp, t) -> "CPSAwait*" $$ [typ t]
-  | CPSAsync (Type.Fut, t) -> "CPSAsync" $$ [typ t]
-  | CPSAsync (Type.Cmp, t) -> "CPSAsync*" $$ [typ t]
+  | CPSAsync (Type.Fut, t, par) -> "CPSAsync" $$ [typ t] @ [exp par]
+  | CPSAsync (Type.Cmp, t, _) -> "CPSAsync*" $$ [typ t]
   | ICArgDataPrim     -> Atom "ICArgDataPrim"
   | ICStableSize t    -> "ICStableSize" $$ [typ t]
   | ICPerformGC       -> Atom "ICPerformGC"
   | ICReplyPrim ts    -> "ICReplyPrim" $$ List.map typ ts
   | ICRejectPrim      -> Atom "ICRejectPrim"
   | ICCallerPrim      -> Atom "ICCallerPrim"
-  | ICCallPrim        -> Atom "ICCallPrim"
+  | ICCallPrim e      -> "ICCallPrim" $$ Option.(map exp e |> to_list)
   | ICCallRawPrim     -> Atom "ICCallRawPrim"
   | ICMethodNamePrim  -> Atom "ICMethodNamePrim"
   | ICStableWrite t   -> "ICStableWrite" $$ [typ t]

src/ir_def/check_ir.ml

@@ -405,7 +405,7 @@ let rec check_exp env (exp:Ir.exp) : unit =
   | PrimE (p, es) ->
     List.iter (check_exp env) es;
     begin match p, es with
-    | CallPrim insts, [exp1; exp2] ->
+    | CallPrim (insts, _FIXMEpars), [exp1; exp2] ->
       begin match T.promote (typ exp1) with
         | T.Func (sort, control, tbs, arg_tys, ret_tys) ->
           check_inst_bounds env tbs insts exp.at;
@@ -556,6 +556,11 @@ let rec check_exp env (exp:Ir.exp) : unit =
       check (T.shared (T.seq ots)) "DeserializeOpt is not defined for operand type";
       typ exp1 <: T.blob;
       T.Opt (T.seq ots) <: t
+
+
+    | ICCyclesPrim, [] -> () (* FIXME *)
+
+
     | CPSAwait (s, cont_typ), [a; krb] ->
       let (_, t1) =
         try T.as_async_sub s T.Non (T.normalize (typ a))
@@ -574,7 +579,7 @@ let rec check_exp env (exp:Ir.exp) : unit =
        | _ -> error env exp.at "CPSAwait bad cont");
       check (not (env.flavor.has_await)) "CPSAwait await flavor";
       check (env.flavor.has_async_typ) "CPSAwait in post-async flavor";
-    | CPSAsync (s, t0), [exp] ->
+    | CPSAsync (s, t0, _FIXME), [exp] ->
       (match typ exp with
        | T.Func (T.Local, T.Returns, [tb],
                  T.[Func (Local, Returns, [], ts1, []);
@@ -601,7 +606,8 @@ let rec check_exp env (exp:Ir.exp) : unit =
       T.Non <: t
     | ICCallerPrim, [] ->
       T.caller <: t
-    | ICCallPrim, [exp1; exp2; k; r; c] ->
+    | ICCallPrim setup, [exp1; exp2; k; r; c] ->
+      Option.iter (fun e -> typ e <: T.unit) setup;
       let t1 = T.promote (typ exp1) in
       begin match t1 with
       | T.Func (sort, T.Replies, _ (*TBR*), arg_tys, ret_tys) ->
@@ -744,7 +750,7 @@ let rec check_exp env (exp:Ir.exp) : unit =
     check_exp (add_lab env id t0) exp1;
     typ exp1 <: t0;
     t0 <: t
-  | AsyncE (s, tb, exp1, t0) ->
+  | AsyncE (_FIXME, s, tb, exp1, t0) ->
     check env.flavor.has_await "async expression in non-await flavor";
     check_typ env t0;
     let c, tb, ce = check_open_typ_bind env tb in
@@ -803,13 +809,15 @@ let rec check_exp env (exp:Ir.exp) : unit =
       , tbs, List.map (T.close cs) ts1, List.map (T.close cs) ret_tys
       ) in
     fun_ty <: t
-  | SelfCallE (ts, exp_f, exp_k, exp_r, exp_c) ->
+  | SelfCallE (cyc, ts, exp_f, exp_k, exp_r, exp_c) ->
     check (not env.flavor.Ir.has_async_typ) "SelfCallE in async flavor";
+    check_exp env cyc;
     List.iter (check_typ env) ts;
     check_exp { env with lvl = NotTopLvl } exp_f;
     check_exp env exp_k;
     check_exp env exp_r;
     check_exp env exp_c;
+    typ cyc <: T.(Opt (Obj (Object, [])));
     typ exp_f <: T.unit;
     typ exp_k <: T.(Construct.contT (Tup ts) unit);
     typ exp_r <: T.(Construct.err_contT unit);