From d4811e20c9de89da20f5d082b7d1b698d2920f9f Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Wed, 10 Jul 2024 13:39:16 +0200 Subject: [PATCH 001/127] WIP: surface syntax for parentheticals --- doc/md/examples/grammar.txt | 1 + src/mo_frontend/parser.mly | 6 ++++++ 2 files changed, 7 insertions(+) diff --git a/doc/md/examples/grammar.txt b/doc/md/examples/grammar.txt index 9b30a88bff1..ff3b9491eda 100644 --- a/doc/md/examples/grammar.txt +++ b/doc/md/examples/grammar.txt @@ -214,6 +214,7 @@ 'break' ? 'continue' 'debug' + '(' ? 'with' , ';')> ')' 'if' 'if' 'else' 'try' diff --git a/src/mo_frontend/parser.mly b/src/mo_frontend/parser.mly index 5ceca1e9e6e..555b12de5a0 100644 --- a/src/mo_frontend/parser.mly +++ b/src/mo_frontend/parser.mly @@ -703,6 +703,12 @@ exp_un(B) : BreakE(x', TupE([]) @? no_region) @? at $sloc } | DEBUG e=exp_nest { DebugE(e) @? at $sloc } + | LPAR base=exp_post(ob)? WITH fs=seplist(exp_field, semicolon) RPAR e=exp_nest (* parentheticals to qualify message sends *) + { match e.it with + | CallE _ + | AsyncE (Type.Fut, _, _) -> e + | _ -> { e with it = ObjE(Option.to_list base, fs) } + } | IF b=exp_nullary(ob) e1=exp_nest %prec IF_NO_ELSE { IfE(b, e1, TupE([]) @? at $sloc) @? at $sloc } | IF b=exp_nullary(ob) e1=exp_nest ELSE e2=exp_nest From b6d32ec7d51e2fbf57a4d180e5f318e911cc28c8 Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Wed, 10 Jul 2024 14:06:56 +0200 Subject: [PATCH 002/127] WIP: first AST modifications --- src/lowering/desugar.ml | 46 ++++++++++++++++----------------- src/mo_def/arrange.ml | 2 +- src/mo_def/syntax.ml | 4 +-- src/mo_frontend/definedness.ml | 2 +- src/mo_frontend/effect.ml | 4 +-- src/mo_frontend/parser.mly | 2 +- src/mo_frontend/traversals.ml | 4 +-- src/mo_frontend/typing.ml | 6 ++--- src/mo_interpreter/interpret.ml | 2 +- src/viper/trans.ml | 2 +- test/run-drun/clone.mo | 4 +-- 11 files changed, 39 insertions(+), 39 deletions(-) diff --git a/src/lowering/desugar.ml b/src/lowering/desugar.ml index f3ffa3cacd5..2acfab3348b 100644 --- a/src/lowering/desugar.ml +++ b/src/lowering/desugar.ml @@ -123,7 +123,7 @@ and exp' at note = function let tys = List.map (T.open_ vars) res_tys in I.FuncE (name, s, control, tbs', args, tys, wrap (exp e)) (* Primitive functions in the prelude have particular shapes *) - | S.CallE ({it=S.AnnotE ({it=S.PrimE p;_}, _);note;_}, _, e) + | S.CallE (None, {it=S.AnnotE ({it=S.PrimE p;_}, _);note;_}, _, e) when Lib.String.chop_prefix "num_conv" p <> None -> begin match String.split_on_char '_' p with | ["num"; "conv"; s1; s2] -> @@ -132,7 +132,7 @@ and exp' at note = function I.PrimE (I.NumConvTrapPrim (p1, p2), [exp e]) | _ -> assert false end - | S.CallE ({it=S.AnnotE ({it=S.PrimE p;_}, _);note;_}, _, e) + | S.CallE (None, {it=S.AnnotE ({it=S.PrimE p;_}, _);note;_}, _, e) when Lib.String.chop_prefix "num_wrap" p <> None -> begin match String.split_on_char '_' p with | ["num"; "wrap"; s1; s2] -> @@ -141,70 +141,70 @@ and exp' at note = function I.PrimE (I.NumConvWrapPrim (p1, p2), [exp e]) | _ -> assert false end - | S.CallE ({it=S.AnnotE ({it=S.PrimE "decodeUtf8";_},_);_}, _, e) -> + | S.CallE (None, {it=S.AnnotE ({it=S.PrimE "decodeUtf8";_},_);_}, _, e) -> I.PrimE (I.DecodeUtf8, [exp e]) - | S.CallE ({it=S.AnnotE ({it=S.PrimE "encodeUtf8";_},_);_}, _, e) -> + | S.CallE (None, {it=S.AnnotE ({it=S.PrimE "encodeUtf8";_},_);_}, _, e) -> I.PrimE (I.EncodeUtf8, [exp e]) - | S.CallE ({it=S.AnnotE ({it=S.PrimE "cast";_}, _);note;_}, _, e) -> + | S.CallE (None, {it=S.AnnotE ({it=S.PrimE "cast";_}, _);note;_}, _, e) -> begin match note.S.note_typ with | T.Func (T.Local, T.Returns, [], ts1, ts2) -> I.PrimE (I.CastPrim (T.seq ts1, T.seq ts2), [exp e]) | _ -> assert false end - | S.CallE ({it=S.AnnotE ({it=S.PrimE "serialize";_}, _);note;_}, _, e) -> + | S.CallE (None, {it=S.AnnotE ({it=S.PrimE "serialize";_}, _);note;_}, _, e) -> begin match note.S.note_typ with | T.Func (T.Local, T.Returns, [], ts1, ts2) -> I.PrimE (I.SerializePrim ts1, [exp e]) | _ -> assert false end - | S.CallE ({it=S.AnnotE ({it=S.PrimE "deserialize";_}, _);note;_}, _, e) -> + | S.CallE (None, {it=S.AnnotE ({it=S.PrimE "deserialize";_}, _);note;_}, _, e) -> begin match note.S.note_typ with | T.Func (T.Local, T.Returns, [], ts1, ts2) -> I.PrimE (I.DeserializePrim ts2, [exp e]) | _ -> assert false end - | S.CallE ({it=S.AnnotE ({it=S.PrimE "caller";_},_);_}, _, {it=S.TupE es;_}) -> + | S.CallE (None, {it=S.AnnotE ({it=S.PrimE "caller";_},_);_}, _, {it=S.TupE es;_}) -> assert (es = []); I.PrimE (I.ICCallerPrim, []) - | S.CallE ({it=S.AnnotE ({it=S.PrimE "time";_},_);_}, _, {it=S.TupE es;_}) -> + | S.CallE (None, {it=S.AnnotE ({it=S.PrimE "time";_},_);_}, _, {it=S.TupE es;_}) -> assert (es = []); I.PrimE (I.SystemTimePrim, []) (* Cycles *) - | S.CallE ({it=S.AnnotE ({it=S.PrimE "cyclesBalance";_},_);_}, _, {it=S.TupE es;_}) -> + | S.CallE (None, {it=S.AnnotE ({it=S.PrimE "cyclesBalance";_},_);_}, _, {it=S.TupE es;_}) -> assert (es = []); I.PrimE (I.SystemCyclesBalancePrim, []) - | S.CallE ({it=S.AnnotE ({it=S.PrimE "cyclesAvailable";_},_);_}, _, {it=S.TupE es;_}) -> + | S.CallE (None, {it=S.AnnotE ({it=S.PrimE "cyclesAvailable";_},_);_}, _, {it=S.TupE es;_}) -> assert (es = []); I.PrimE (I.SystemCyclesAvailablePrim, []) - | S.CallE ({it=S.AnnotE ({it=S.PrimE "cyclesRefunded";_},_);_}, _, {it=S.TupE es;_}) -> + | S.CallE (None, {it=S.AnnotE ({it=S.PrimE "cyclesRefunded";_},_);_}, _, {it=S.TupE es;_}) -> assert (es = []); I.PrimE (I.SystemCyclesRefundedPrim, []) - | S.CallE ({it=S.AnnotE ({it=S.PrimE "cyclesAccept";_},_);_}, _, e) -> + | S.CallE (None, {it=S.AnnotE ({it=S.PrimE "cyclesAccept";_},_);_}, _, e) -> I.PrimE (I.SystemCyclesAcceptPrim, [exp e]) - | S.CallE ({it=S.AnnotE ({it=S.PrimE "cyclesAdd";_},_);_}, _, e) -> + | S.CallE (None, {it=S.AnnotE ({it=S.PrimE "cyclesAdd";_},_);_}, _, e) -> I.PrimE (I.SystemCyclesAddPrim, [exp e]) (* Certified data *) - | S.CallE ({it=S.AnnotE ({it=S.PrimE "setCertifiedData";_},_);_}, _, e) -> + | S.CallE (None, {it=S.AnnotE ({it=S.PrimE "setCertifiedData";_},_);_}, _, e) -> I.PrimE (I.SetCertifiedData, [exp e]) - | S.CallE ({it=S.AnnotE ({it=S.PrimE "getCertificate";_},_);_}, _, {it=S.TupE es;_}) -> + | S.CallE (None, {it=S.AnnotE ({it=S.PrimE "getCertificate";_},_);_}, _, {it=S.TupE es;_}) -> I.PrimE (I.GetCertificate, []) (* Other *) - | S.CallE ({it=S.AnnotE ({it=S.PrimE p;_},_);_}, _, {it=S.TupE es;_}) -> + | S.CallE (None, {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) -> + | S.CallE (None, {it=S.AnnotE ({it=S.PrimE p;_},_);_}, _, e) -> I.PrimE (I.OtherPrim p, [exp e]) (* Optimizing array.size() *) - | S.CallE ({it=S.DotE (e1, proj); _}, _, {it=S.TupE [];_}) + | S.CallE (None, {it=S.DotE (e1, proj); _}, _, {it=S.TupE [];_}) when T.is_array e1.note.S.note_typ && proj.it = "size" -> I.PrimE (I.OtherPrim "array_len", [exp e1]) - | S.CallE ({it=S.DotE (e1, proj); _}, _, {it=S.TupE [];_}) + | S.CallE (None, {it=S.DotE (e1, proj); _}, _, {it=S.TupE [];_}) when T.(is_prim Text) e1.note.S.note_typ && proj.it = "size" -> I.PrimE (I.OtherPrim "text_len", [exp e1]) - | S.CallE ({it=S.DotE (e1, proj); _}, _, {it=S.TupE [];_}) + | S.CallE (None, {it=S.DotE (e1, proj); _}, _, {it=S.TupE [];_}) when T.(is_prim Blob) e1.note.S.note_typ && proj.it = "size" -> I.PrimE (I.OtherPrim "blob_size", [exp e1]) (* Normal call *) - | S.CallE (e1, inst, e2) -> + | S.CallE (_FIXME, e1, inst, e2) -> I.PrimE (I.CallPrim inst.note, [exp e1; exp e2]) | S.BlockE [] -> (unitE ()).it | S.BlockE [{it = S.ExpD e; _}] -> (exp e).it @@ -220,7 +220,7 @@ and exp' at note = function | S.WhileE (e1, e2) -> (whileE (exp e1) (exp e2)).it | S.LoopE (e1, None) -> I.LoopE (exp e1) | S.LoopE (e1, Some e2) -> (loopWhileE (exp e1) (exp e2)).it - | S.ForE (p, {it=S.CallE ({it=S.DotE (arr, proj); _}, _, e1); _}, e2) + | S.ForE (p, {it=S.CallE (None, {it=S.DotE (arr, proj); _}, _, e1); _}, e2) when T.is_array arr.note.S.note_typ && (proj.it = "vals" || proj.it = "keys") -> (transform_for_to_while p arr proj e1 e2).it | S.ForE (p, e1, e2) -> (forE (pat p) (exp e1) (exp e2)).it diff --git a/src/mo_def/arrange.ml b/src/mo_def/arrange.ml index 22da9f70a56..3976082c6dd 100644 --- a/src/mo_def/arrange.ml +++ b/src/mo_def/arrange.ml @@ -87,7 +87,7 @@ module Make (Cfg : Config) = struct Atom (if sugar then "" else "="); exp e' ] - | CallE (e1, ts, e2) -> "CallE" $$ [exp e1] @ inst ts @ [exp e2] + | CallE (_FIXME, e1, ts, e2) -> "CallE" $$ [exp e1] @ inst ts @ [exp e2] | BlockE ds -> "BlockE" $$ List.map dec ds | NotE e -> "NotE" $$ [exp e] | AndE (e1, e2) -> "AndE" $$ [exp e1; exp e2] diff --git a/src/mo_def/syntax.ml b/src/mo_def/syntax.ml index a23421ea6ed..6950332d652 100644 --- a/src/mo_def/syntax.ml +++ b/src/mo_def/syntax.ml @@ -171,8 +171,8 @@ and exp' = | ArrayE of mut * exp list (* array *) | IdxE of exp * exp (* array indexing *) | FuncE of string * sort_pat * typ_bind list * pat * typ option * sugar * exp (* function *) - | CallE of exp * inst * exp (* function call *) - | BlockE of dec list (* block (with type after avoidance)*) + | CallE of exp option * exp * inst * exp (* function call *) + | BlockE of dec list (* block (with type after avoidance) *) | NotE of exp (* negation *) | AndE of exp * exp (* conjunction *) | OrE of exp * exp (* disjunction *) diff --git a/src/mo_frontend/definedness.ml b/src/mo_frontend/definedness.ml index af8b6c99624..302edc1e02b 100644 --- a/src/mo_frontend/definedness.ml +++ b/src/mo_frontend/definedness.ml @@ -82,7 +82,7 @@ let rec exp msgs e : f = match e.it with (* Eager uses are either first-class uses of a variable: *) | VarE i -> M.singleton i.it Eager (* Or anything that is occurring in a call (as this may call a closure): *) - | CallE (e1, ts, e2) -> eagerify (exps msgs [e1; e2]) + | CallE (_FIXME, e1, ts, e2) -> eagerify (exps msgs [e1; e2]) (* And break, return, throw can be thought of as calling a continuation: *) | BreakE (i, e) -> eagerify (exp msgs e) | RetE e -> eagerify (exp msgs e) diff --git a/src/mo_frontend/effect.ml b/src/mo_frontend/effect.ml index dff82f13d24..aa05f3a6424 100644 --- a/src/mo_frontend/effect.ml +++ b/src/mo_frontend/effect.ml @@ -49,7 +49,7 @@ let effect_exp (exp:Syntax.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:Syntax.exp) : T.eff = match exp.it with - | CallE (exp1, inst, exp2) when is_async_call exp1 inst exp2 -> + | CallE (_FIXME, exp1, inst, exp2) when is_async_call exp1 inst exp2 -> T.Await | PrimE _ | VarE _ @@ -81,7 +81,7 @@ let rec infer_effect_exp (exp:Syntax.exp) : T.eff = | IdxE (exp1, exp2) | RelE (_, exp1, _, exp2) | AssignE (exp1, exp2) - | CallE (exp1, _, exp2) + | CallE (_(*FIXME*), exp1, _, exp2) | AndE (exp1, exp2) | OrE (exp1, exp2) | ImpliesE (exp1, exp2) diff --git a/src/mo_frontend/parser.mly b/src/mo_frontend/parser.mly index 555b12de5a0..181632f803d 100644 --- a/src/mo_frontend/parser.mly +++ b/src/mo_frontend/parser.mly @@ -605,7 +605,7 @@ exp_post(B) : | e=exp_post(B) DOT x=id { DotE(e, x) @? at $sloc } | e1=exp_post(B) inst=inst e2=exp_nullary(ob) - { CallE(e1, inst, e2) @? at $sloc } + { CallE(None, e1, inst, e2) @? at $sloc } | e1=exp_post(B) BANG { BangE(e1) @? at $sloc } | LPAR SYSTEM e1=exp_post(B) DOT x=id RPAR diff --git a/src/mo_frontend/traversals.ml b/src/mo_frontend/traversals.ml index db769cefbd0..cbccff8b335 100644 --- a/src/mo_frontend/traversals.ml +++ b/src/mo_frontend/traversals.ml @@ -31,8 +31,8 @@ let rec over_exp (f : exp -> exp) (exp : exp) : exp = match exp.it with f { exp with it = RelE (x, over_exp f exp1, y, over_exp f exp2) } | AssignE (exp1, exp2) -> f { exp with it = AssignE (over_exp f exp1, over_exp f exp2) } - | CallE (exp1, x, exp2) -> - f { exp with it = CallE (over_exp f exp1, x, over_exp f exp2) } + | CallE (par_opt, exp1, x, exp2) -> + f { exp with it = CallE (Option.map (over_exp f) par_opt, over_exp f exp1, x, over_exp f exp2) } | AndE (exp1, exp2) -> f { exp with it = AndE (over_exp f exp1, over_exp f exp2) } | OrE (exp1, exp2) -> diff --git a/src/mo_frontend/typing.ml b/src/mo_frontend/typing.ml index 136bdf4c708..0b133044247 100644 --- a/src/mo_frontend/typing.ml +++ b/src/mo_frontend/typing.ml @@ -947,7 +947,7 @@ let rec is_explicit_exp e = true | LitE l -> is_explicit_lit !l | UnE (_, _, e1) | OptE e1 | DoOptE e1 - | ProjE (e1, _) | DotE (e1, _) | BangE e1 | IdxE (e1, _) | CallE (e1, _, _) + | ProjE (e1, _) | DotE (e1, _) | BangE e1 | IdxE (e1, _) | CallE (_(*FIXME: correct?*), e1, _, _) | LabelE (_, _, e1) | AsyncE (_, _, e1) | AwaitE (_, e1) -> is_explicit_exp e1 | BinE (_, e1, _, e2) | IfE (_, e1, e2) -> @@ -1483,7 +1483,7 @@ and infer_exp'' env exp : T.typ = end; let ts1 = match pat.it with TupP _ -> T.seq_of_tup t1 | _ -> [t1] in T.Func (sort, c, T.close_binds cs tbs, List.map (T.close cs) ts1, List.map (T.close cs) ts2) - | CallE (exp1, inst, exp2) -> + | CallE (_FIXME, exp1, inst, exp2) -> infer_call env exp1 inst exp2 exp.at None | BlockE decs -> let t, _ = infer_block env decs exp.at false in @@ -1868,7 +1868,7 @@ and check_exp' env0 t exp : T.typ = in check_exp_strong (adjoin_vals env' ve2) t2 exp; t - | CallE (exp1, inst, exp2), _ -> + | CallE (_FIXME, exp1, inst, exp2), _ -> let t' = infer_call env exp1 inst exp2 exp.at (Some t) in if not (T.sub t' t) then local_error env0 exp.at "M0096" diff --git a/src/mo_interpreter/interpret.ml b/src/mo_interpreter/interpret.ml index 8537e4e74fe..95f52a9672d 100644 --- a/src/mo_interpreter/interpret.ml +++ b/src/mo_interpreter/interpret.ml @@ -570,7 +570,7 @@ and interpret_exp_mut env exp (k : V.value V.cont) = | T.Shared _ -> make_message env name exp.note.note_typ v | T.Local -> v in k v' - | CallE (exp1, typs, exp2) -> + | CallE (_FIXME, exp1, typs, exp2) -> interpret_exp env exp1 (fun v1 -> interpret_exp env exp2 (fun v2 -> let call_conv, f = V.as_func v1 in diff --git a/src/viper/trans.ml b/src/viper/trans.ml index 454e079d6f6..1337cf223ba 100644 --- a/src/viper/trans.ml +++ b/src/viper/trans.ml @@ -416,7 +416,7 @@ and stmt ctxt (s : M.exp) : seqn = | M.AssertE (M.Runtime, e) -> !!([], [ !!(AssumeS (exp ctxt e)) ]) - | M.(CallE({it = VarE m; _}, inst, {it = TupE args; _})) -> + | M.(CallE(_, {it = VarE m; _}, inst, {it = TupE args; _})) -> !!([], [ !!(MethodCallS ([], id m, let self_var = self ctxt m.at in diff --git a/test/run-drun/clone.mo b/test/run-drun/clone.mo index 6a6df77ed03..767fda3dee5 100644 --- a/test/run-drun/clone.mo +++ b/test/run-drun/clone.mo @@ -8,8 +8,8 @@ actor Cloner { // passing itself as first argument, using available funds public shared func makeCloneable(init : Nat): async Lib.Cloneable { let accepted = Cycles.accept(Cycles.available()); - Cycles.add(accepted); - await Lib.Cloneable(makeCloneable, init); + Cycles.add(accepted); // FIXME: remove + await (with cycles = accepted) Lib.Cloneable(makeCloneable, init); }; public shared func test() : async () { From d3b94157728bab72b2e679e20811fe88e66391fc Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Wed, 10 Jul 2024 15:13:31 +0200 Subject: [PATCH 003/127] WIP: augment IR too --- src/ir_def/arrange_ir.ml | 2 +- src/ir_def/check_ir.ml | 2 +- src/ir_def/construct.ml | 8 ++++++-- src/ir_def/ir.ml | 4 ++-- src/ir_interpreter/interpret_ir.ml | 2 +- src/ir_passes/async.ml | 2 +- src/ir_passes/tailcall.ml | 4 ++-- src/lowering/desugar.ml | 2 +- 8 files changed, 15 insertions(+), 11 deletions(-) diff --git a/src/ir_def/arrange_ir.ml b/src/ir_def/arrange_ir.ml index 7b68f595f6d..8dc9b90ac63 100644 --- a/src/ir_def/arrange_ir.ml +++ b/src/ir_def/arrange_ir.ml @@ -57,7 +57,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] diff --git a/src/ir_def/check_ir.ml b/src/ir_def/check_ir.ml index e9c0e0d84a9..3be9e1c261f 100644 --- a/src/ir_def/check_ir.ml +++ b/src/ir_def/check_ir.ml @@ -398,7 +398,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; diff --git a/src/ir_def/construct.ml b/src/ir_def/construct.ml index 8c0a52a2bb9..ce3ddf8fd46 100644 --- a/src/ir_def/construct.ml +++ b/src/ir_def/construct.ml @@ -312,6 +312,8 @@ let funcE name sort ctrl typ_binds args typs exp = note = Note.{ def with typ; eff = T.Triv }; } +let recordE' = ref (fun _ -> nullE ()) (* gets correctly filled below *) + let callE exp1 typs exp2 = let typ = match T.promote (typ exp1) with | T.Func (_sort, control, _, _, ret_tys) -> @@ -319,7 +321,7 @@ let callE exp1 typs exp2 = | T.Non -> T.Non | _ -> raise (Invalid_argument "callE expect a function") in - let p = CallPrim typs in + let p = CallPrim (typs, !recordE' []) in let es = [exp1; exp2] in { it = PrimE (p, es); at = no_region; @@ -351,7 +353,7 @@ let orE : Ir.exp -> Ir.exp -> Ir.exp = fun e1 e2 -> let impliesE : Ir.exp -> Ir.exp -> Ir.exp = fun e1 e2 -> orE (notE e1) e2 let oldE : Ir.exp -> Ir.exp = fun e -> - { it = (primE (CallPrim [typ e]) [e]).it; + { it = (primE (CallPrim ([typ e], !recordE' [])) [e]).it; at = no_region; note = Note.{ def with typ = typ e; @@ -771,6 +773,8 @@ let objE sort typ_flds flds = let recordE flds = objE T.Object [] flds +let _ = recordE' := recordE + let check_call_perform_status success mk_failure = ifE (callE diff --git a/src/ir_def/ir.ml b/src/ir_def/ir.ml index f58bdb9567a..ccbbe8f0e54 100644 --- a/src/ir_def/ir.ml +++ b/src/ir_def/ir.ml @@ -113,7 +113,7 @@ and lexp' = all call-by-value. Many passes can treat them uniformly, so they are unified using the PrimE node. *) and prim = - | CallPrim of Type.typ list (* function call *) + | CallPrim of Type.typ list * exp (* function call *) | UnPrim of Type.typ * unop (* unary operator *) | BinPrim of Type.typ * binop (* binary operator *) | RelPrim of Type.typ * relop (* relational operator *) @@ -257,7 +257,7 @@ let replace_obj_pat pfs pats = let map_prim t_typ t_id p = match p with - | CallPrim ts -> CallPrim (List.map t_typ ts) + | CallPrim (ts, _FIXME) -> CallPrim (List.map t_typ ts, _FIXME) | UnPrim (ot, op) -> UnPrim (t_typ ot, op) | BinPrim (ot, op) -> BinPrim (t_typ ot, op) | RelPrim (ot, op) -> RelPrim (t_typ ot, op) diff --git a/src/ir_interpreter/interpret_ir.ml b/src/ir_interpreter/interpret_ir.ml index f8c245b5769..2a6e8c8df71 100644 --- a/src/ir_interpreter/interpret_ir.ml +++ b/src/ir_interpreter/interpret_ir.ml @@ -310,7 +310,7 @@ and interpret_exp_mut env exp (k : V.value V.cont) = | PrimE (p, es) -> interpret_exps env es [] (fun vs -> match p, vs with - | CallPrim typs, [v1; v2] -> + | CallPrim (typs, _), [v1; v2] -> let call_conv, f = V.as_func v1 in check_call_conv (List.hd es) call_conv; check_call_conv_arg env exp v2 call_conv; diff --git a/src/ir_passes/async.ml b/src/ir_passes/async.ml index 5d4a000cabf..cc76eefdaf3 100644 --- a/src/ir_passes/async.ml +++ b/src/ir_passes/async.ml @@ -308,7 +308,7 @@ let transform prog = let v_ret = fresh_var "v" t_ret in let v_fail = fresh_var "e" t_fail in ([v_ret; v_fail] -->* (callE (t_exp exp1) [t0] (tupE [varE v_ret; varE v_fail]))).it - | PrimE (CallPrim typs, [exp1; exp2]) when is_awaitable_func exp1 -> + | PrimE (CallPrim (typs, _FIXME), [exp1; exp2]) when is_awaitable_func exp1 -> let ts1,ts2 = match typ exp1 with | T.Func (T.Shared _, T.Promises, tbs, ts1, ts2) -> diff --git a/src/ir_passes/tailcall.ml b/src/ir_passes/tailcall.ml index 3734fc8409e..31c4ee02434 100644 --- a/src/ir_passes/tailcall.ml +++ b/src/ir_passes/tailcall.ml @@ -94,14 +94,14 @@ and assignEs vars exp : dec list = and exp' env e : exp' = match e.it with | VarE _ | LitE _ -> e.it | AssignE (e1, e2) -> AssignE (lexp env e1, exp env e2) - | PrimE (CallPrim insts, [e1; e2]) -> + | PrimE (CallPrim (insts, pars), [e1; e2]) -> begin match e1.it, env with | VarE f1, { tail_pos = true; info = Some { func; typ_binds; temps; label; tail_called } } when f1 = func && are_generic_insts typ_binds insts -> tail_called := true; (blockE (assignEs temps (exp env e2)) (breakE label (unitE ()))).it - | _,_-> PrimE (CallPrim insts, [exp env e1; exp env e2]) + | _,_-> PrimE (CallPrim (insts, pars), [exp env e1; exp env e2]) end | BlockE (ds, e) -> BlockE (block env ds e) | IfE (e1, e2, e3) -> IfE (exp env e1, tailexp env e2, tailexp env e3) diff --git a/src/lowering/desugar.ml b/src/lowering/desugar.ml index 2acfab3348b..f8e3ff55dcf 100644 --- a/src/lowering/desugar.ml +++ b/src/lowering/desugar.ml @@ -205,7 +205,7 @@ and exp' at note = function I.PrimE (I.OtherPrim "blob_size", [exp e1]) (* Normal call *) | S.CallE (_FIXME, e1, inst, e2) -> - I.PrimE (I.CallPrim inst.note, [exp e1; exp e2]) + I.PrimE (I.CallPrim (inst.note, Option.(value ~default:(recordE []) (map exp _FIXME))), [exp e1; exp e2]) | S.BlockE [] -> (unitE ()).it | S.BlockE [{it = S.ExpD e; _}] -> (exp e).it | S.BlockE ds -> I.BlockE (block (T.is_unit note.Note.typ) ds) From 3f57777427f5d1e3bcac41a03a7943620ac26df2 Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Wed, 10 Jul 2024 15:55:44 +0200 Subject: [PATCH 004/127] Update src/mo_frontend/definedness.ml --- src/mo_frontend/definedness.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/mo_frontend/definedness.ml b/src/mo_frontend/definedness.ml index 302edc1e02b..bd02e599d41 100644 --- a/src/mo_frontend/definedness.ml +++ b/src/mo_frontend/definedness.ml @@ -82,7 +82,7 @@ let rec exp msgs e : f = match e.it with (* Eager uses are either first-class uses of a variable: *) | VarE i -> M.singleton i.it Eager (* Or anything that is occurring in a call (as this may call a closure): *) - | CallE (_FIXME, e1, ts, e2) -> eagerify (exps msgs [e1; e2]) + | CallE (_FIXME, e1, ts, e2) -> eagerify (exps msgs [e1; e2]) (* And break, return, throw can be thought of as calling a continuation: *) | BreakE (i, e) -> eagerify (exp msgs e) | RetE e -> eagerify (exp msgs e) From 7e23ac85b12020d50d7b04580d9373bbb8858a43 Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Wed, 10 Jul 2024 16:40:11 +0200 Subject: [PATCH 005/127] WIP: fill the parenthetical unfortunately it doesn't arrive in the `async.ml` --- src/ir_passes/async.ml | 7 ++++--- src/lowering/desugar.ml | 4 ++-- src/mo_frontend/parser.mly | 3 ++- src/mo_frontend/typing.ml | 2 ++ 4 files changed, 10 insertions(+), 6 deletions(-) diff --git a/src/ir_passes/async.ml b/src/ir_passes/async.ml index cc76eefdaf3..67d098e333d 100644 --- a/src/ir_passes/async.ml +++ b/src/ir_passes/async.ml @@ -290,7 +290,7 @@ let transform prog = v --> (ic_replyE ts1 (varE v)) in let ic_reject = let e = fresh_var "e" T.catch in - [e] -->* (ic_rejectE (errorMessageE (varE e))) in + e --> (ic_rejectE (errorMessageE (varE e))) in let exp' = callE (t_exp exp1) [t0] (tupE [ic_reply; ic_reject]) in expD (selfcallE ts1 exp' (varE nary_reply) (varE reject)) ] @@ -309,6 +309,7 @@ let transform prog = let v_fail = fresh_var "e" t_fail in ([v_ret; v_fail] -->* (callE (t_exp exp1) [t0] (tupE [varE v_ret; varE v_fail]))).it | PrimE (CallPrim (typs, _FIXME), [exp1; exp2]) when is_awaitable_func exp1 -> + assert T.(as_obj (t_typ _FIXME.note.typ) = (Object, [])); let ts1,ts2 = match typ exp1 with | T.Func (T.Shared _, T.Promises, tbs, ts1, ts2) -> @@ -396,7 +397,7 @@ let transform prog = v --> (ic_replyE ret_tys (varE v)) in let r = let e = fresh_var "e" T.catch in - [e] -->* (ic_rejectE (errorMessageE (varE e))) in + e --> (ic_rejectE (errorMessageE (varE e))) in let exp' = callE (t_exp cps) [t0] (tupE [k;r]) in FuncE (x, T.Shared s', Replies, typbinds', args', ret_tys, exp') (* oneway, always with `ignore(async _)` body *) @@ -425,7 +426,7 @@ let transform prog = v --> tupE [] in (* discard return *) let r = let e = fresh_var "e" T.catch in - [e] -->* tupE [] in (* discard error *) + e --> tupE [] in (* discard error *) let exp' = callE (t_exp cps) [t0] (tupE [k;r]) in FuncE (x, T.Shared s', Returns, typbinds', args', ret_tys, exp') | Returns, _ -> diff --git a/src/lowering/desugar.ml b/src/lowering/desugar.ml index f8e3ff55dcf..9ba0d790e6c 100644 --- a/src/lowering/desugar.ml +++ b/src/lowering/desugar.ml @@ -204,8 +204,8 @@ and exp' at note = function when T.(is_prim Blob) e1.note.S.note_typ && proj.it = "size" -> I.PrimE (I.OtherPrim "blob_size", [exp e1]) (* Normal call *) - | S.CallE (_FIXME, e1, inst, e2) -> - I.PrimE (I.CallPrim (inst.note, Option.(value ~default:(recordE []) (map exp _FIXME))), [exp e1; exp e2]) + | S.CallE (par_opt, e1, inst, e2) -> + I.PrimE (I.CallPrim (inst.note, Option.(value ~default:(recordE []) (map exp par_opt))), [exp e1; exp e2]) | S.BlockE [] -> (unitE ()).it | S.BlockE [{it = S.ExpD e; _}] -> (exp e).it | S.BlockE ds -> I.BlockE (block (T.is_unit note.Note.typ) ds) diff --git a/src/mo_frontend/parser.mly b/src/mo_frontend/parser.mly index 181632f803d..f68ef11f554 100644 --- a/src/mo_frontend/parser.mly +++ b/src/mo_frontend/parser.mly @@ -705,7 +705,8 @@ exp_un(B) : { DebugE(e) @? at $sloc } | LPAR base=exp_post(ob)? WITH fs=seplist(exp_field, semicolon) RPAR e=exp_nest (* parentheticals to qualify message sends *) { match e.it with - | CallE _ + | CallE (None, f, is, args) -> + { e with it = CallE (Some (ObjE(Option.to_list base, fs) @? e.at), f, is, args) } | AsyncE (Type.Fut, _, _) -> e | _ -> { e with it = ObjE(Option.to_list base, fs) } } diff --git a/src/mo_frontend/typing.ml b/src/mo_frontend/typing.ml index 0b133044247..e4c2c8c5ad0 100644 --- a/src/mo_frontend/typing.ml +++ b/src/mo_frontend/typing.ml @@ -1484,6 +1484,7 @@ and infer_exp'' env exp : T.typ = let ts1 = match pat.it with TupP _ -> T.seq_of_tup t1 | _ -> [t1] in T.Func (sort, c, T.close_binds cs tbs, List.map (T.close cs) ts1, List.map (T.close cs) ts2) | CallE (_FIXME, exp1, inst, exp2) -> + ignore (Option.map (infer_exp env) _FIXME); infer_call env exp1 inst exp2 exp.at None | BlockE decs -> let t, _ = infer_block env decs exp.at false in @@ -1869,6 +1870,7 @@ and check_exp' env0 t exp : T.typ = check_exp_strong (adjoin_vals env' ve2) t2 exp; t | CallE (_FIXME, exp1, inst, exp2), _ -> + ignore (Option.map (infer_exp env) _FIXME); let t' = infer_call env exp1 inst exp2 exp.at (Some t) in if not (T.sub t' t) then local_error env0 exp.at "M0096" From b0516b0290ac76508e18831fcc6fe52e6ddf26f3 Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Wed, 10 Jul 2024 16:48:52 +0200 Subject: [PATCH 006/127] tweaks --- src/ir_passes/tailcall.ml | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/ir_passes/tailcall.ml b/src/ir_passes/tailcall.ml index 31c4ee02434..80482c79a44 100644 --- a/src/ir_passes/tailcall.ml +++ b/src/ir_passes/tailcall.ml @@ -94,11 +94,11 @@ and assignEs vars exp : dec list = and exp' env e : exp' = match e.it with | VarE _ | LitE _ -> e.it | AssignE (e1, e2) -> AssignE (lexp env e1, exp env e2) - | PrimE (CallPrim (insts, pars), [e1; e2]) -> + | PrimE (CallPrim (insts, pars), [e1; e2]) -> begin match e1.it, env with | VarE f1, { tail_pos = true; info = Some { func; typ_binds; temps; label; tail_called } } - when f1 = func && are_generic_insts typ_binds insts -> + when f1 = func && are_generic_insts typ_binds insts -> tail_called := true; (blockE (assignEs temps (exp env e2)) (breakE label (unitE ()))).it | _,_-> PrimE (CallPrim (insts, pars), [exp env e1; exp env e2]) @@ -136,7 +136,7 @@ and lexp env le : lexp = {le with it = lexp' env le} and lexp' env le : lexp' = match le.it with | VarLE i -> VarLE i - | DotLE (e, sn) -> DotLE (exp env e, sn) + | DotLE (e, sn) -> DotLE (exp env e, sn) | IdxLE (e1, e2) -> IdxLE (exp env e1, exp env e2) and args env as_ = @@ -256,7 +256,7 @@ and block env ds exp = and comp_unit env = function | LibU _ -> raise (Invalid_argument "cannot compile library") | ProgU ds -> ProgU (snd (decs env ds)) - | ActorU (as_opt, ds, fs, u, t) -> + | ActorU (as_opt, ds, fs, u, t) -> let u = { u with preupgrade = exp env u.preupgrade; postupgrade = exp env u.postupgrade } in ActorU (as_opt, snd (decs env ds), fs, u, t) From dc5a72fbd010ed279c7cd0248a028713a7acaf66 Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Wed, 10 Jul 2024 17:35:45 +0200 Subject: [PATCH 007/127] define and use `tupVarsP` helper --- src/ir_def/construct.ml | 2 ++ src/ir_def/construct.mli | 1 + src/ir_passes/async.ml | 14 +++++++------- 3 files changed, 10 insertions(+), 7 deletions(-) diff --git a/src/ir_def/construct.ml b/src/ir_def/construct.ml index ce3ddf8fd46..d9cc65dfea4 100644 --- a/src/ir_def/construct.ml +++ b/src/ir_def/construct.ml @@ -62,6 +62,8 @@ let tupP pats = note = T.Tup (List.map (fun p -> p.note) pats); at = no_region } +let tupVarsP vs = List.map varP vs |> tupP + let seqP ps = match ps with | [p] -> p diff --git a/src/ir_def/construct.mli b/src/ir_def/construct.mli index 731568f94a2..a1c8fceb314 100644 --- a/src/ir_def/construct.mli +++ b/src/ir_def/construct.mli @@ -39,6 +39,7 @@ val typ_arg : con -> bind_sort -> typ -> typ_bind val varP : var -> pat val tupP : pat list -> pat +val tupVarsP : var list -> pat val wildP : pat val seqP : pat list -> pat diff --git a/src/ir_passes/async.ml b/src/ir_passes/async.ml index 67d098e333d..6384f082253 100644 --- a/src/ir_passes/async.ml +++ b/src/ir_passes/async.ml @@ -117,7 +117,7 @@ let new_nary_async_reply ts = fresh_var "reject" (typ_of_var fail) in (async, reply, reject), - blockE [letP (tupP [varP unary_async; varP unary_fulfill; varP fail]) call_new_async] + blockE [letP (tupVarsP [unary_async; unary_fulfill; fail]) call_new_async] (tupE [nary_async; nary_reply; varE fail]) @@ -149,8 +149,8 @@ let let_seq ts e d_of_vs = (letP p e)::d_of_vs [x] | ts -> let xs = fresh_vars "x" ts in - let p = tupP (List.map varP xs) in - (letP p e)::d_of_vs (xs) + let p = tupVarsP xs in + (letP p e) :: d_of_vs xs (* name e in f unless named already *) let ensureNamed e f = @@ -284,7 +284,7 @@ let transform prog = new_nary_async_reply ts1 in ( blockE [ - letP (tupP [varP nary_async; varP nary_reply; varP reject]) def; + letP (tupVarsP [nary_async; nary_reply; reject]) def; let ic_reply = (* flatten v, here and below? *) let v = fresh_var "v" (T.seq ts1) in v --> (ic_replyE ts1 (varE v)) in @@ -309,7 +309,7 @@ let transform prog = let v_fail = fresh_var "e" t_fail in ([v_ret; v_fail] -->* (callE (t_exp exp1) [t0] (tupE [varE v_ret; varE v_fail]))).it | PrimE (CallPrim (typs, _FIXME), [exp1; exp2]) when is_awaitable_func exp1 -> - assert T.(as_obj (t_typ _FIXME.note.typ) = (Object, [])); + (*assert T.(as_obj _FIXME.note.typ = (Object, []));*) let ts1,ts2 = match typ exp1 with | T.Func (T.Shared _, T.Promises, tbs, ts1, ts2) -> @@ -323,7 +323,7 @@ let transform prog = new_nary_async_reply ts2 in (blockE ( - letP (tupP [varP nary_async; varP nary_reply; varP reject]) def :: + letP (tupVarsP [nary_async; nary_reply; reject]) def :: let_eta exp1' (fun v1 -> let_seq ts1 exp2' (fun vs -> [ expD (ic_callE v1 (seqE (List.map varE vs)) (varE nary_reply) (varE reject)) ] @@ -338,7 +338,7 @@ let transform prog = let exp3' = t_exp exp3 in let ((nary_async, nary_reply, reject), def) = new_nary_async_reply [T.blob] in (blockE ( - letP (tupP [varP nary_async; varP nary_reply; varP reject]) def :: + letP (tupVarsP [nary_async; nary_reply; reject]) def :: let_eta exp1' (fun v1 -> let_eta exp2' (fun v2 -> let_eta exp3' (fun v3 -> From 8f7df27e53a667e578093cca430c7429cc5a940f Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Wed, 10 Jul 2024 18:32:54 +0200 Subject: [PATCH 008/127] teach about `SystemCyclesAddPrim` --- src/ir_def/construct.ml | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/ir_def/construct.ml b/src/ir_def/construct.ml index d9cc65dfea4..6e5e388aa79 100644 --- a/src/ir_def/construct.ml +++ b/src/ir_def/construct.ml @@ -93,7 +93,8 @@ let primE prim es = | ICStableRead t -> t | ICMethodNamePrim -> T.text | ICPerformGC - | ICStableWrite _ -> T.unit + | ICStableWrite _ + | SystemCyclesAddPrim -> T.unit | ICStableSize _ -> T.nat64 | IdxPrim | DerefArrayOffset -> T.(as_immut (as_array_sub (List.hd es).note.Note.typ)) @@ -371,7 +372,7 @@ let dotE exp name typ = { it = PrimE (DotPrim name, [exp]); at = no_region; note = Note.{ def with - typ = typ; + typ; eff = eff exp } } From e5f3ca9e056263679d416d423a665f58b72cdd7d Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Wed, 10 Jul 2024 18:34:46 +0200 Subject: [PATCH 009/127] examine all exprs --- src/ir_passes/tailcall.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/ir_passes/tailcall.ml b/src/ir_passes/tailcall.ml index 80482c79a44..03f15ed6df6 100644 --- a/src/ir_passes/tailcall.ml +++ b/src/ir_passes/tailcall.ml @@ -101,7 +101,7 @@ and exp' env e : exp' = match e.it with when f1 = func && are_generic_insts typ_binds insts -> tail_called := true; (blockE (assignEs temps (exp env e2)) (breakE label (unitE ()))).it - | _,_-> PrimE (CallPrim (insts, pars), [exp env e1; exp env e2]) + | _,_-> PrimE (CallPrim (insts, exp env pars), [exp env e1; exp env e2]) end | BlockE (ds, e) -> BlockE (block env ds e) | IfE (e1, e2, e3) -> IfE (exp env e1, tailexp env e2, tailexp env e3) From 5eb79a312339a889bf458a6203d9ab27a24562f1 Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Wed, 10 Jul 2024 18:36:42 +0200 Subject: [PATCH 010/127] WIP: doing naughty stuff at least now I get > ingress Err: IC0504: Canister rwlgt-iiaaa-aaaaa-aaaaa-cai violated contract: ic0_call_cycles_add128 called when no call is under construction. --- src/ir_passes/async.ml | 13 ++++++++++--- 1 file changed, 10 insertions(+), 3 deletions(-) diff --git a/src/ir_passes/async.ml b/src/ir_passes/async.ml index 6384f082253..5bb03c3edbb 100644 --- a/src/ir_passes/async.ml +++ b/src/ir_passes/async.ml @@ -308,8 +308,7 @@ let transform prog = let v_ret = fresh_var "v" t_ret in let v_fail = fresh_var "e" t_fail in ([v_ret; v_fail] -->* (callE (t_exp exp1) [t0] (tupE [varE v_ret; varE v_fail]))).it - | PrimE (CallPrim (typs, _FIXME), [exp1; exp2]) when is_awaitable_func exp1 -> - (*assert T.(as_obj _FIXME.note.typ = (Object, []));*) + | PrimE (CallPrim (typs, pars), [exp1; exp2]) when is_awaitable_func exp1 -> let ts1,ts2 = match typ exp1 with | T.Func (T.Shared _, T.Promises, tbs, ts1, ts2) -> @@ -322,11 +321,19 @@ let transform prog = let ((nary_async, nary_reply, reject), def) = new_nary_async_reply ts2 in + let (Object, pars_fs) = T.(as_obj pars.note.typ) in + assert Type.(pars_fs = [] || sub pars.note.typ (Obj(Object, [{ lab = "cycles"; typ = nat; src = empty_src}]))); + (*assert T.(as_obj _FIXME.note.typ = (Object, []));*) + let hasCycles = Type.(sub pars.note.typ (Obj(Object, [{ lab = "cycles"; typ = nat; src = empty_src}]))) in + let addCycles = function + | true -> fun decs -> + expD (primE SystemCyclesAddPrim [dotE pars "cycles" T.nat]) :: decs + | false -> fun decs -> decs in (blockE ( letP (tupVarsP [nary_async; nary_reply; reject]) def :: let_eta exp1' (fun v1 -> let_seq ts1 exp2' (fun vs -> - [ expD (ic_callE v1 (seqE (List.map varE vs)) (varE nary_reply) (varE reject)) ] + addCycles hasCycles [ expD (ic_callE v1 (seqE (List.map varE vs)) (varE nary_reply) (varE reject)) ] ) ) ) From 9672a9612b785ba7ac3e96c5271b26458bfed2f6 Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Wed, 10 Jul 2024 18:49:56 +0200 Subject: [PATCH 011/127] WIP: this starts working we should use the system call though, instead of assigning to `@cycles`, as that will go away --- src/ir_passes/async.ml | 7 +++---- test/run-drun/clone.mo | 7 ++++--- test/run-drun/clone/cloneable.mo | 1 + 3 files changed, 8 insertions(+), 7 deletions(-) diff --git a/src/ir_passes/async.ml b/src/ir_passes/async.ml index 5bb03c3edbb..8156202bafc 100644 --- a/src/ir_passes/async.ml +++ b/src/ir_passes/async.ml @@ -323,17 +323,16 @@ let transform prog = in let (Object, pars_fs) = T.(as_obj pars.note.typ) in assert Type.(pars_fs = [] || sub pars.note.typ (Obj(Object, [{ lab = "cycles"; typ = nat; src = empty_src}]))); - (*assert T.(as_obj _FIXME.note.typ = (Object, []));*) let hasCycles = Type.(sub pars.note.typ (Obj(Object, [{ lab = "cycles"; typ = nat; src = empty_src}]))) in - let addCycles = function + let storeCycles = function | true -> fun decs -> - expD (primE SystemCyclesAddPrim [dotE pars "cycles" T.nat]) :: decs + expD T.(dotE pars "cycles" nat |> assignE (var "@cycles" (Mut nat))) :: decs | false -> fun decs -> decs in (blockE ( letP (tupVarsP [nary_async; nary_reply; reject]) def :: let_eta exp1' (fun v1 -> let_seq ts1 exp2' (fun vs -> - addCycles hasCycles [ expD (ic_callE v1 (seqE (List.map varE vs)) (varE nary_reply) (varE reject)) ] + storeCycles hasCycles [ expD (ic_callE v1 (seqE (List.map varE vs)) (varE nary_reply) (varE reject)) ] ) ) ) diff --git a/test/run-drun/clone.mo b/test/run-drun/clone.mo index 767fda3dee5..a1e178a9ce7 100644 --- a/test/run-drun/clone.mo +++ b/test/run-drun/clone.mo @@ -18,9 +18,10 @@ actor Cloner { await Cycles.provisional_top_up_actor(Cloner, 100_000_000_000_000); // create the original Cloneable object - Cycles.add(10_000_000_000_000); - let c0 : Lib.Cloneable = await makeCloneable(0); - await c0.someMethod(); // prints 1 + Cycles.add(10_000_000_000_000); // FIXME: remove (arrives in `async.ml`) + let c0 : Lib.Cloneable = await (with cycles = 10_000_000_000_000) makeCloneable(0); + Cycles.add(41_000_000); // FIXME: remove + await (with cycles = 42_000_000) c0.someMethod(); // prints 1 Prim.debugPrint(debug_show(Prim.principalOfActor c0)); // create some proper clones diff --git a/test/run-drun/clone/cloneable.mo b/test/run-drun/clone/cloneable.mo index 8dded284eaa..e9fd4b562d2 100644 --- a/test/run-drun/clone/cloneable.mo +++ b/test/run-drun/clone/cloneable.mo @@ -16,6 +16,7 @@ actor class Cloneable( public func someMethod() : async () { state += 1; Prim.debugPrint(debug_show(state)); + Prim.debugPrint(debug_show Cycles.available()); }; // our clone methods, indirecting through makeCloneable From 00b250755602bd87ce010b10e6e1dc0145039302 Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Wed, 10 Jul 2024 18:50:26 +0200 Subject: [PATCH 012/127] accept --- test/run-drun/ok/clone.drun-run.ok | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/test/run-drun/ok/clone.drun-run.ok b/test/run-drun/ok/clone.drun-run.ok index 3a37cf62bbf..f8b60fd257b 100644 --- a/test/run-drun/ok/clone.drun-run.ok +++ b/test/run-drun/ok/clone.drun-run.ok @@ -2,12 +2,16 @@ ingress Completed: Reply: 0x4449444c016c01b3c4b1f204680100010a000000000000000001 ingress Completed: Reply: 0x4449444c0000 debug.print: 0 debug.print: 1 +debug.print: 42_000_000 debug.print: rrkah-fqaaa-aaaaa-aaaaq-cai debug.print: 1 debug.print: 2 +debug.print: 0 debug.print: ryjl3-tyaaa-aaaaa-aaaba-cai debug.print: 2 debug.print: 3 +debug.print: 0 debug.print: r7inp-6aaaa-aaaaa-aaabq-cai debug.print: 2 +debug.print: 0 ingress Completed: Reply: 0x4449444c0000 From 3d4bb5a3267c7b3bd7aed1b242e5ab258a4df8a7 Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Wed, 10 Jul 2024 18:51:43 +0200 Subject: [PATCH 013/127] cleanup --- test/run-drun/clone.mo | 1 - 1 file changed, 1 deletion(-) diff --git a/test/run-drun/clone.mo b/test/run-drun/clone.mo index a1e178a9ce7..986645079ef 100644 --- a/test/run-drun/clone.mo +++ b/test/run-drun/clone.mo @@ -20,7 +20,6 @@ actor Cloner { // create the original Cloneable object Cycles.add(10_000_000_000_000); // FIXME: remove (arrives in `async.ml`) let c0 : Lib.Cloneable = await (with cycles = 10_000_000_000_000) makeCloneable(0); - Cycles.add(41_000_000); // FIXME: remove await (with cycles = 42_000_000) c0.someMethod(); // prints 1 Prim.debugPrint(debug_show(Prim.principalOfActor c0)); From d989397fb96b5371227377537e7ee0f8055404ca Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Wed, 10 Jul 2024 22:21:41 +0200 Subject: [PATCH 014/127] compress --- src/ir_passes/async.ml | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/src/ir_passes/async.ml b/src/ir_passes/async.ml index 8156202bafc..ef98bd4620e 100644 --- a/src/ir_passes/async.ml +++ b/src/ir_passes/async.ml @@ -339,9 +339,7 @@ let transform 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 exp1', exp2', exp3' = t_exp exp1, t_exp exp2, t_exp exp3 in let ((nary_async, nary_reply, reject), def) = new_nary_async_reply [T.blob] in (blockE ( letP (tupVarsP [nary_async; nary_reply; reject]) def :: From 892ea54dac327f7962be4d9c0ec3f48876fbedf2 Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Thu, 11 Jul 2024 11:52:58 +0200 Subject: [PATCH 015/127] WIP: prepare `ICCallPrim` to carry setup code --- src/codegen/compile.ml | 2 +- src/ir_def/arrange_ir.ml | 2 +- src/ir_def/check_ir.ml | 3 ++- src/ir_def/construct.ml | 4 ++-- src/ir_def/construct.mli | 2 +- src/ir_def/ir.ml | 5 ++--- src/ir_interpreter/interpret_ir.ml | 2 +- src/ir_passes/async.ml | 2 +- 8 files changed, 11 insertions(+), 11 deletions(-) diff --git a/src/codegen/compile.ml b/src/codegen/compile.ml index bbce0ee1646..c5ca8cf79e0 100644 --- a/src/codegen/compile.ml +++ b/src/codegen/compile.ml @@ -11783,7 +11783,7 @@ and compile_prim_invocation (env : E.t) ae p es at = | ICCallerPrim, [] -> SR.Vanilla, IC.caller env - | ICCallPrim, [f;e;k;r] -> + | ICCallPrim _, [f;e;k;r] -> SR.unit, begin (* TBR: Can we do better than using the notes? *) let _, _, _, ts1, _ = Type.as_func f.note.Note.typ in diff --git a/src/ir_def/arrange_ir.ml b/src/ir_def/arrange_ir.ml index 8dc9b90ac63..d2c6b3eacb1 100644 --- a/src/ir_def/arrange_ir.ml +++ b/src/ir_def/arrange_ir.ml @@ -111,7 +111,7 @@ and prim = function | ICReplyPrim ts -> "ICReplyPrim" $$ List.map typ ts | ICRejectPrim -> Atom "ICRejectPrim" | ICCallerPrim -> Atom "ICCallerPrim" - | ICCallPrim -> Atom "ICCallPrim" + | ICCallPrim _FIXME -> Atom "ICCallPrim" | ICCallRawPrim -> Atom "ICCallRawPrim" | ICMethodNamePrim -> Atom "ICMethodNamePrim" | ICStableWrite t -> "ICStableWrite" $$ [typ t] diff --git a/src/ir_def/check_ir.ml b/src/ir_def/check_ir.ml index 3be9e1c261f..179f3059774 100644 --- a/src/ir_def/check_ir.ml +++ b/src/ir_def/check_ir.ml @@ -593,7 +593,8 @@ let rec check_exp env (exp:Ir.exp) : unit = T.Non <: t | ICCallerPrim, [] -> T.caller <: t - | ICCallPrim, [exp1; exp2; k; r] -> + | ICCallPrim setup, [exp1; exp2; k; r] -> + 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) -> diff --git a/src/ir_def/construct.ml b/src/ir_def/construct.ml index 6e5e388aa79..227c9f0f69a 100644 --- a/src/ir_def/construct.ml +++ b/src/ir_def/construct.ml @@ -186,11 +186,11 @@ let ic_rejectE e = note = Note.{ def with typ = T.unit; eff = eff e } } -let ic_callE f e k r = +let ic_callE s f e k r = let es = [f; e; k; r] in let effs = List.map eff es in let eff = List.fold_left max_eff T.Triv effs in - { it = PrimE (ICCallPrim, es); + { it = PrimE (ICCallPrim s, es); at = no_region; note = Note.{ def with typ = T.unit; eff = eff } } diff --git a/src/ir_def/construct.mli b/src/ir_def/construct.mli index a1c8fceb314..3785e49f186 100644 --- a/src/ir_def/construct.mli +++ b/src/ir_def/construct.mli @@ -56,7 +56,7 @@ val cps_asyncE : async_sort -> typ -> typ -> exp -> exp val cps_awaitE : async_sort -> 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_callE : exp option -> exp -> exp -> exp -> exp -> exp val ic_call_rawE : exp -> exp -> exp -> exp -> exp -> exp val projE : exp -> int -> exp val optE : exp -> exp diff --git a/src/ir_def/ir.ml b/src/ir_def/ir.ml index ccbbe8f0e54..1769e02310b 100644 --- a/src/ir_def/ir.ml +++ b/src/ir_def/ir.ml @@ -168,7 +168,7 @@ and prim = | ICReplyPrim of Type.typ list | ICRejectPrim | ICCallerPrim - | ICCallPrim + | ICCallPrim of exp option | ICCallRawPrim | ICMethodNamePrim | ICArgDataPrim @@ -307,10 +307,9 @@ let map_prim t_typ t_id p = | ICPerformGC | ICRejectPrim | ICCallerPrim - | ICCallPrim + | ICCallPrim _ (* FIXME: how to transform this? *) | ICCallRawPrim | ICMethodNamePrim -> p | ICStableWrite t -> ICStableWrite (t_typ t) | ICStableRead t -> ICStableRead (t_typ t) | ICStableSize t -> ICStableSize (t_typ t) - diff --git a/src/ir_interpreter/interpret_ir.ml b/src/ir_interpreter/interpret_ir.ml index 2a6e8c8df71..5fdc580edd2 100644 --- a/src/ir_interpreter/interpret_ir.ml +++ b/src/ir_interpreter/interpret_ir.ml @@ -446,7 +446,7 @@ and interpret_exp_mut env exp (k : V.value V.cont) = let reject = Option.get env.rejects in let e = V.Tup [V.Variant ("canister_reject", V.unit); v1] in Scheduler.queue (fun () -> reject e) - | ICCallPrim, [v1; v2; kv; rv] -> + | ICCallPrim _, [v1; v2; kv; rv] -> let call_conv, f = V.as_func v1 in check_call_conv (List.hd es) call_conv; check_call_conv_arg env exp v2 call_conv; diff --git a/src/ir_passes/async.ml b/src/ir_passes/async.ml index ef98bd4620e..d106806f635 100644 --- a/src/ir_passes/async.ml +++ b/src/ir_passes/async.ml @@ -332,7 +332,7 @@ let transform prog = letP (tupVarsP [nary_async; nary_reply; reject]) def :: let_eta exp1' (fun v1 -> let_seq ts1 exp2' (fun vs -> - storeCycles hasCycles [ expD (ic_callE v1 (seqE (List.map varE vs)) (varE nary_reply) (varE reject)) ] + storeCycles hasCycles [ expD (ic_callE None(*FIXME*) v1 (seqE (List.map varE vs)) (varE nary_reply) (varE reject)) ] ) ) ) From 42a0471cb8765b325d974d07ef836e165e5fbb43 Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Thu, 11 Jul 2024 13:05:11 +0200 Subject: [PATCH 016/127] WIP: compile the setup code --- src/codegen/compile.ml | 6 ++++-- src/ir_def/construct.mli | 2 +- src/ir_passes/async.ml | 9 ++++++++- 3 files changed, 13 insertions(+), 4 deletions(-) diff --git a/src/codegen/compile.ml b/src/codegen/compile.ml index c5ca8cf79e0..3d1dbf9963e 100644 --- a/src/codegen/compile.ml +++ b/src/codegen/compile.ml @@ -11783,7 +11783,7 @@ and compile_prim_invocation (env : E.t) ae p es at = | ICCallerPrim, [] -> SR.Vanilla, IC.caller env - | ICCallPrim _, [f;e;k;r] -> + | ICCallPrim setup, [f;e;k;r] -> SR.unit, begin (* TBR: Can we do better than using the notes? *) let _, _, _, ts1, _ = Type.as_func f.note.Note.typ in @@ -11792,7 +11792,9 @@ and compile_prim_invocation (env : E.t) ae p es at = 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 + 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 ^^ diff --git a/src/ir_def/construct.mli b/src/ir_def/construct.mli index 3785e49f186..d4d979c2c0c 100644 --- a/src/ir_def/construct.mli +++ b/src/ir_def/construct.mli @@ -141,7 +141,7 @@ val seqE : exp list -> exp val (-->) : var -> exp -> exp val (-->*) : var list -> exp -> exp (* n-ary local *) val forall : typ_bind list -> exp -> exp (* generalization *) -val (-*-) : exp -> exp -> exp (* application *) +val (-*-) : exp -> exp -> exp (* application *) (* Objects *) diff --git a/src/ir_passes/async.ml b/src/ir_passes/async.ml index d106806f635..194cce82fdb 100644 --- a/src/ir_passes/async.ml +++ b/src/ir_passes/async.ml @@ -328,11 +328,18 @@ let transform prog = | true -> fun decs -> expD T.(dotE pars "cycles" nat |> assignE (var "@cycles" (Mut nat))) :: decs | false -> fun decs -> decs in + + + let setup = if hasCycles + then Some (primE SystemCyclesAddPrim [dotE pars "cycles" T.nat]) + else None in + + (blockE ( letP (tupVarsP [nary_async; nary_reply; reject]) def :: let_eta exp1' (fun v1 -> let_seq ts1 exp2' (fun vs -> - storeCycles hasCycles [ expD (ic_callE None(*FIXME*) v1 (seqE (List.map varE vs)) (varE nary_reply) (varE reject)) ] + storeCycles false [ expD (ic_callE setup v1 (seqE (List.map varE vs)) (varE nary_reply) (varE reject)) ] ) ) ) From e43b1cc2f624ca6e5f735c42dce817765ad423a4 Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Thu, 11 Jul 2024 16:20:50 +0200 Subject: [PATCH 017/127] elim a FIXME --- src/ir_def/arrange_ir.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/ir_def/arrange_ir.ml b/src/ir_def/arrange_ir.ml index d2c6b3eacb1..cfaf326ec13 100644 --- a/src/ir_def/arrange_ir.ml +++ b/src/ir_def/arrange_ir.ml @@ -111,7 +111,7 @@ and prim = function | ICReplyPrim ts -> "ICReplyPrim" $$ List.map typ ts | ICRejectPrim -> Atom "ICRejectPrim" | ICCallerPrim -> Atom "ICCallerPrim" - | ICCallPrim _FIXME -> Atom "ICCallPrim" + | ICCallPrim e -> "ICCallPrim" $$ Option.(map exp e |> to_list) | ICCallRawPrim -> Atom "ICCallRawPrim" | ICMethodNamePrim -> Atom "ICMethodNamePrim" | ICStableWrite t -> "ICStableWrite" $$ [typ t] From 43e816c7f9a70546bf6e559ec7c3c7e82253cf26 Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Thu, 11 Jul 2024 16:53:14 +0200 Subject: [PATCH 018/127] minor refactor --- src/ir_def/construct.ml | 3 +++ src/ir_def/construct.mli | 1 + src/ir_passes/async.ml | 8 +++++--- 3 files changed, 9 insertions(+), 3 deletions(-) diff --git a/src/ir_def/construct.ml b/src/ir_def/construct.ml index 227c9f0f69a..bde04cd6b75 100644 --- a/src/ir_def/construct.ml +++ b/src/ir_def/construct.ml @@ -480,6 +480,9 @@ let assignE v exp2 = note = Note.{ def with typ = T.unit; eff = eff exp2 }; } +let assignVarE v exp = + assignE (var v T.(Mut (typ exp |> as_immut))) exp + let labelE l typ exp = { it = LabelE (l, typ, exp); at = no_region; diff --git a/src/ir_def/construct.mli b/src/ir_def/construct.mli index d4d979c2c0c..b7c961734d9 100644 --- a/src/ir_def/construct.mli +++ b/src/ir_def/construct.mli @@ -91,6 +91,7 @@ val breakE: id -> exp -> exp val retE: exp -> exp val immuteE: exp -> exp val assignE : var -> exp -> exp +val assignVarE : id -> exp -> exp val labelE : id -> typ -> exp -> exp val loopE : exp -> exp val forE : pat -> exp -> exp -> exp diff --git a/src/ir_passes/async.ml b/src/ir_passes/async.ml index 194cce82fdb..e647a397698 100644 --- a/src/ir_passes/async.ml +++ b/src/ir_passes/async.ml @@ -326,12 +326,14 @@ let transform prog = let hasCycles = Type.(sub pars.note.typ (Obj(Object, [{ lab = "cycles"; typ = nat; src = empty_src}]))) in let storeCycles = function | true -> fun decs -> - expD T.(dotE pars "cycles" nat |> assignE (var "@cycles" (Mut nat))) :: decs + expD (dotE pars "cycles" T.nat |> assignVarE "@cycles") :: decs | false -> fun decs -> decs in let setup = if hasCycles - then Some (primE SystemCyclesAddPrim [dotE pars "cycles" T.nat]) + then Some (thenE + (natE Mo_values.Numerics.Nat.zero |> assignVarE "@cycles") + (primE SystemCyclesAddPrim [dotE pars "cycles" T.nat])) else None in @@ -339,7 +341,7 @@ let transform prog = letP (tupVarsP [nary_async; nary_reply; reject]) def :: let_eta exp1' (fun v1 -> let_seq ts1 exp2' (fun vs -> - storeCycles false [ expD (ic_callE setup v1 (seqE (List.map varE vs)) (varE nary_reply) (varE reject)) ] + (*storeCycles false*) [ expD (ic_callE setup v1 (seqE (List.map varE vs)) (varE nary_reply) (varE reject)) ] ) ) ) From 2f22db2c0a672d7a9e94bbcede24fce4cfafe892 Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Thu, 11 Jul 2024 18:34:42 +0200 Subject: [PATCH 019/127] explain more cycles --- test/run-drun/clone.mo | 1 + test/run-drun/ok/clone.drun-run.ok | 3 +++ 2 files changed, 4 insertions(+) diff --git a/test/run-drun/clone.mo b/test/run-drun/clone.mo index 986645079ef..321ce7db4cf 100644 --- a/test/run-drun/clone.mo +++ b/test/run-drun/clone.mo @@ -8,6 +8,7 @@ actor Cloner { // passing itself as first argument, using available funds public shared func makeCloneable(init : Nat): async Lib.Cloneable { let accepted = Cycles.accept(Cycles.available()); + Prim.debugPrint(debug_show {accepted}); Cycles.add(accepted); // FIXME: remove await (with cycles = accepted) Lib.Cloneable(makeCloneable, init); }; diff --git a/test/run-drun/ok/clone.drun-run.ok b/test/run-drun/ok/clone.drun-run.ok index f8b60fd257b..3530bf68883 100644 --- a/test/run-drun/ok/clone.drun-run.ok +++ b/test/run-drun/ok/clone.drun-run.ok @@ -1,13 +1,16 @@ ingress Completed: Reply: 0x4449444c016c01b3c4b1f204680100010a00000000000000000101 ingress Completed: Reply: 0x4449444c0000 +debug.print: {accepted = 10_000_000_000_000} debug.print: 0 debug.print: 1 debug.print: 42_000_000 debug.print: rrkah-fqaaa-aaaaa-aaaaq-cai +debug.print: {accepted = 5_000_000_000_000} debug.print: 1 debug.print: 2 debug.print: 0 debug.print: ryjl3-tyaaa-aaaaa-aaaba-cai +debug.print: {accepted = 2_500_000_000_000} debug.print: 2 debug.print: 3 debug.print: 0 From b6ee8dd8e146bea5e6245ada49eb919131c4f68c Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Thu, 11 Jul 2024 18:47:05 +0200 Subject: [PATCH 020/127] remove because redundant --- test/run-drun/clone.mo | 1 - 1 file changed, 1 deletion(-) diff --git a/test/run-drun/clone.mo b/test/run-drun/clone.mo index 321ce7db4cf..1feaf4b5735 100644 --- a/test/run-drun/clone.mo +++ b/test/run-drun/clone.mo @@ -19,7 +19,6 @@ actor Cloner { await Cycles.provisional_top_up_actor(Cloner, 100_000_000_000_000); // create the original Cloneable object - Cycles.add(10_000_000_000_000); // FIXME: remove (arrives in `async.ml`) let c0 : Lib.Cloneable = await (with cycles = 10_000_000_000_000) makeCloneable(0); await (with cycles = 42_000_000) c0.someMethod(); // prints 1 Prim.debugPrint(debug_show(Prim.principalOfActor c0)); From 812d78d23418893db7fd19a1bf819133b798c923 Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Thu, 11 Jul 2024 19:39:01 +0200 Subject: [PATCH 021/127] fix IR renaming --- src/ir_def/ir.ml | 6 +++--- src/ir_def/rename.ml | 4 ++-- src/ir_passes/async.ml | 5 +++-- src/ir_passes/erase_typ_field.ml | 5 +++-- test/run-drun/clone/cloneable.mo | 3 +-- 5 files changed, 12 insertions(+), 11 deletions(-) diff --git a/src/ir_def/ir.ml b/src/ir_def/ir.ml index 1769e02310b..d8cde38b9fe 100644 --- a/src/ir_def/ir.ml +++ b/src/ir_def/ir.ml @@ -255,9 +255,9 @@ let replace_obj_pat pfs pats = (* Helper for transforming prims, without missing embedded typs and ids *) -let map_prim t_typ t_id p = +let map_prim t_typ t_id t_exp p = match p with - | CallPrim (ts, _FIXME) -> CallPrim (List.map t_typ ts, _FIXME) + | CallPrim (ts, par) -> CallPrim (List.map t_typ ts, t_exp par) | UnPrim (ot, op) -> UnPrim (t_typ ot, op) | BinPrim (ot, op) -> BinPrim (t_typ ot, op) | RelPrim (ot, op) -> RelPrim (t_typ ot, op) @@ -307,9 +307,9 @@ let map_prim t_typ t_id p = | ICPerformGC | ICRejectPrim | ICCallerPrim - | ICCallPrim _ (* FIXME: how to transform this? *) | ICCallRawPrim | ICMethodNamePrim -> p + | ICCallPrim setup -> ICCallPrim (Option.map t_exp setup) | ICStableWrite t -> ICStableWrite (t_typ t) | ICStableRead t -> ICStableRead (t_typ t) | ICStableSize t -> ICStableSize (t_typ t) diff --git a/src/ir_def/rename.ml b/src/ir_def/rename.ml index 0a14e5da22a..f702f81fefe 100644 --- a/src/ir_def/rename.ml +++ b/src/ir_def/rename.ml @@ -25,8 +25,8 @@ let arg_bind rho a = let i' = fresh_id a.it in ({a with it = i'}, Renaming.add a.it i' rho) -let rec prim rho p = - Ir.map_prim (fun t -> t) (id rho) p (* rename BreakPrim id etc *) +let rec prim rho = + Ir.map_prim (fun t -> t) (id rho) (exp rho) (* rename BreakPrim id etc *) and exp rho e = {e with it = exp' rho e.it} and exp' rho = function diff --git a/src/ir_passes/async.ml b/src/ir_passes/async.ml index e647a397698..8b17518e6ae 100644 --- a/src/ir_passes/async.ml +++ b/src/ir_passes/async.ml @@ -227,8 +227,6 @@ let transform prog = Type.set_kind clone (t_kind (Cons.kind c)); clone - and t_prim p = Ir.map_prim t_typ (fun id -> id) p - and t_field {lab; typ; src} = { lab; typ = t_typ typ; src } in @@ -241,6 +239,9 @@ let transform prog = }; at = exp.at; } + + and t_prim p = Ir.map_prim t_typ (fun id -> id) t_exp p + and t_exp' (exp:exp) = let exp' = exp.it in match exp' with diff --git a/src/ir_passes/erase_typ_field.ml b/src/ir_passes/erase_typ_field.ml index 3a999ebe0a9..86296809b14 100644 --- a/src/ir_passes/erase_typ_field.ml +++ b/src/ir_passes/erase_typ_field.ml @@ -83,8 +83,6 @@ let transform prog = Type.set_kind clone (t_kind (Cons.kind c)); clone - and t_prim p = Ir.map_prim t_typ (fun id -> id) p - and t_field {lab; typ; src} = { lab; typ = t_typ typ; src } in @@ -97,6 +95,9 @@ let transform prog = }; at = exp.at; } + + and t_prim p = Ir.map_prim t_typ (fun id -> id) t_exp p + and t_exp' (exp : exp) = let exp' = exp.it in match exp' with diff --git a/test/run-drun/clone/cloneable.mo b/test/run-drun/clone/cloneable.mo index e9fd4b562d2..4760052928b 100644 --- a/test/run-drun/clone/cloneable.mo +++ b/test/run-drun/clone/cloneable.mo @@ -21,7 +21,6 @@ actor class Cloneable( // our clone methods, indirecting through makeCloneable public func clone(init : Nat) : async Cloneable { - Cycles.add(Cycles.balance() / 2); - await makeCloneable(init : Nat); + await (with cycles = Cycles.balance() / 2) makeCloneable init; } } From e7f13f6c94d52d7b1d5a7651a3c40106e8345df7 Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Thu, 11 Jul 2024 20:30:19 +0200 Subject: [PATCH 022/127] cleanup --- src/ir_passes/async.ml | 9 ++------- 1 file changed, 2 insertions(+), 7 deletions(-) diff --git a/src/ir_passes/async.ml b/src/ir_passes/async.ml index 8b17518e6ae..f43bda68c8e 100644 --- a/src/ir_passes/async.ml +++ b/src/ir_passes/async.ml @@ -323,13 +323,8 @@ let transform prog = new_nary_async_reply ts2 in let (Object, pars_fs) = T.(as_obj pars.note.typ) in - assert Type.(pars_fs = [] || sub pars.note.typ (Obj(Object, [{ lab = "cycles"; typ = nat; src = empty_src}]))); let hasCycles = Type.(sub pars.note.typ (Obj(Object, [{ lab = "cycles"; typ = nat; src = empty_src}]))) in - let storeCycles = function - | true -> fun decs -> - expD (dotE pars "cycles" T.nat |> assignVarE "@cycles") :: decs - | false -> fun decs -> decs in - + assert (pars_fs = [] || hasCycles); (* FIXME: remove *) let setup = if hasCycles then Some (thenE @@ -342,7 +337,7 @@ let transform prog = letP (tupVarsP [nary_async; nary_reply; reject]) def :: let_eta exp1' (fun v1 -> let_seq ts1 exp2' (fun vs -> - (*storeCycles false*) [ expD (ic_callE setup v1 (seqE (List.map varE vs)) (varE nary_reply) (varE reject)) ] + [ expD (ic_callE setup v1 (seqE (List.map varE vs)) (varE nary_reply) (varE reject)) ] ) ) ) From ccd03db20f206266d5cbf7b33f44c58702e06117 Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Thu, 11 Jul 2024 21:52:12 +0200 Subject: [PATCH 023/127] tweaks --- src/ir_passes/await.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/ir_passes/await.ml b/src/ir_passes/await.ml index 3cf213b2b2e..7ef19bdc480 100644 --- a/src/ir_passes/await.ml +++ b/src/ir_passes/await.ml @@ -594,7 +594,7 @@ and t_comp_unit context = function let e = fresh_var "e" T.catch in ProgU [ funcD throw e (assertE (falseE ())); - expD (c_block context' ds (tupE []) (meta (T.unit) (fun v1 -> tupE []))) + expD (c_block context' ds (tupE []) (meta T.unit (fun v1 -> tupE []))) ] end | ActorU (as_opt, ds, ids, { meta = m; preupgrade; postupgrade; heartbeat; timer; inspect}, t) -> @@ -619,7 +619,7 @@ and t_ignore_throw context exp = { (blockE [ funcD throw e (tupE[]); ] - (c_exp context' exp (meta (T.unit) (fun v1 -> tupE [])))) + (c_exp context' exp (meta T.unit (fun v1 -> tupE [])))) (* timer logic requires us to preserve any source location, or timer won't be initialized in compile.ml *) with at = exp.at From dbe054d300c3e62d1d368f62fe6a180a673498a9 Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Sun, 14 Jul 2024 15:52:40 +0200 Subject: [PATCH 024/127] tweak --- src/codegen/compile.ml | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/codegen/compile.ml b/src/codegen/compile.ml index 3d1dbf9963e..aae959e75cc 100644 --- a/src/codegen/compile.ml +++ b/src/codegen/compile.ml @@ -10590,8 +10590,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 From 835502cd606f92382464f859549a27380bdd231c Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Sun, 14 Jul 2024 19:09:24 +0200 Subject: [PATCH 025/127] generate less lambdas on the fly instead call into the new `@coerce_cont`. --- src/ir_passes/async.ml | 2 +- src/prelude/internals.mo | 2 ++ 2 files changed, 3 insertions(+), 1 deletion(-) diff --git a/src/ir_passes/async.ml b/src/ir_passes/async.ml index f43bda68c8e..a8cf44dfffb 100644 --- a/src/ir_passes/async.ml +++ b/src/ir_passes/async.ml @@ -84,7 +84,7 @@ let new_nary_async_reply ts = [k; r] -->* ( varE unary_async -*- (tupE [ - [v] -->* (varE k -*- varE v); + varE (var "@coerce_cont" (k --> ([v] -->* unitE()) |> typ)) -*- varE k; varE r ]) ) diff --git a/src/prelude/internals.mo b/src/prelude/internals.mo index 596a2fa2c2e..d4687de0c0d 100644 --- a/src/prelude/internals.mo +++ b/src/prelude/internals.mo @@ -307,6 +307,8 @@ func @getSystemRefund() : @Refund { return (prim "cyclesRefunded" : () -> Nat) (); }; +func @coerce_cont(k : () -> ()) : @Cont<()> = func() = k (); + func @new_async() : (@Async, @Cont, @Cont) { let w_null = func(r : @Refund, t : T) { }; let r_null = func(_ : Error) {}; From b104f854db7cf87ebf9462cf06e9383b772dbccf Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Sun, 14 Jul 2024 21:31:45 +0200 Subject: [PATCH 026/127] integrate also the invocation of the `unary_async` --- src/ir_passes/async.ml | 11 ++--------- src/prelude/internals.mo | 7 ++++++- 2 files changed, 8 insertions(+), 10 deletions(-) diff --git a/src/ir_passes/async.ml b/src/ir_passes/async.ml index a8cf44dfffb..864a3cef648 100644 --- a/src/ir_passes/async.ml +++ b/src/ir_passes/async.ml @@ -78,16 +78,9 @@ let new_nary_async_reply ts = (* construct the n-ary async value, coercing the continuation, if necessary *) let nary_async = let coerce u = - let v = fresh_var "v" u in let k = fresh_var "k" (contT u T.unit) in - let r = fresh_var "r" (err_contT T.unit) in - [k; r] -->* ( - varE unary_async -*- - (tupE [ - varE (var "@coerce_cont" (k --> ([v] -->* unitE()) |> typ)) -*- varE k; - varE r - ]) - ) + varE (var "@coerce_and_cont" (unary_async --> ([k; fail] -->* (varE unary_async -*- tupE [varE unary_fulfill; varE fail])) |> typ)) + -*- varE unary_async in match ts with | [t1] -> diff --git a/src/prelude/internals.mo b/src/prelude/internals.mo index d4687de0c0d..e6b9c300636 100644 --- a/src/prelude/internals.mo +++ b/src/prelude/internals.mo @@ -307,7 +307,12 @@ func @getSystemRefund() : @Refund { return (prim "cyclesRefunded" : () -> Nat) (); }; -func @coerce_cont(k : () -> ()) : @Cont<()> = func() = k (); +func @coerce_and_cont(a : @Async<()>) : + (k : () -> (), r : @Cont) -> { + #suspend; + #schedule : () -> () + } = + func(k, r) = a(func() = k(), r); func @new_async() : (@Async, @Cont, @Cont) { let w_null = func(r : @Refund, t : T) { }; From eaa577d1cd76a43b943058b9f402dc5e9595dc08 Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Wed, 17 Jul 2024 16:38:10 +0200 Subject: [PATCH 027/127] merge corrections --- src/viper/prep.ml | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/src/viper/prep.ml b/src/viper/prep.ml index 29f362f8558..24dbc8978ea 100644 --- a/src/viper/prep.ml +++ b/src/viper/prep.ml @@ -30,18 +30,18 @@ let string_of_mono_goal (g : mono_goal) : string = | _ -> unsupported Source.no_region (Mo_types.Arrange_type.typ t)) g.mg_typs) let mono_calls_visitor (stk : mono_goal Stack.t) : visitor = - { visit_exp = (function - | {it = CallE({it = VarE v; at = v_at; note = v_note},inst,e); at; note} -> - let goal = { mg_id = v.it; mg_typs = inst.note } in - let _ = (if goal.mg_typs = [] then () else Stack.push goal stk) in - let s = string_of_mono_goal goal in - {it = CallE({it = VarE (s @@ v_at); at=v_at; note=v_note}, - {it = None; at=inst.at; note = []}, e); at; note} - | e -> e); - visit_typ = (fun t -> t); + { visit_typ = (fun t -> t); visit_pat = (fun p -> p); visit_dec = (fun d -> d); visit_inst = (fun i -> i); + visit_exp = function + | {it = CallE(_, {it = VarE v; at = v_at; note = v_note},inst,e); _} as exp -> + let goal = { mg_id = v.it; mg_typs = inst.note } in + let _ = (if goal.mg_typs = [] then () else Stack.push goal stk) in + let s = string_of_mono_goal goal in + {exp with it = CallE(None, {it = VarE (s @@ v_at); at=v_at; note=v_note}, + {it = None; at=inst.at; note = []}, e)} + | e -> e } let mono_calls_dec_field (df : dec_field) : (mono_goal list * dec_field) = @@ -143,4 +143,4 @@ let prep_unit (u : comp_unit) : comp_unit = let body' = ActorU(id_opt, decs') in (* let _ = List.map (fun d -> print_endline (Wasm.Sexpr.to_string 80 (Arrange.dec_field d))) decs' in *) { u with it = {imports; body = { body with it = body' } } } - | _ -> u \ No newline at end of file + | _ -> u From 4f770843a91e05cd6ced9bc255c2b097bd6b3831 Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Wed, 17 Jul 2024 20:04:40 +0200 Subject: [PATCH 028/127] WIP: start defining prims --- src/ir_def/arrange_ir.ml | 1 + src/ir_def/check_ir.ml | 5 +++++ src/ir_def/construct.ml | 1 + src/ir_def/ir.ml | 2 ++ src/ir_passes/await.ml | 3 +++ src/viper/trans.ml | 10 +++++----- src/viper/traversals.ml | 2 +- test/run-drun/clone.mo | 1 + 8 files changed, 19 insertions(+), 6 deletions(-) diff --git a/src/ir_def/arrange_ir.ml b/src/ir_def/arrange_ir.ml index 13756c8e524..a950f3cb395 100644 --- a/src/ir_def/arrange_ir.ml +++ b/src/ir_def/arrange_ir.ml @@ -98,6 +98,7 @@ and prim = function | SystemCyclesAvailablePrim -> Atom "SystemCyclesAvailablePrim" | SystemCyclesBalancePrim -> Atom "SystemCyclesBalancePrim" | SystemCyclesRefundedPrim -> Atom "SystemCyclesRefundedPrim" + | ICCyclesPrim -> Atom "ICCyclesPrim" | SetCertifiedData -> Atom "SetCertifiedData" | GetCertificate -> Atom "GetCertificate" | OtherPrim s -> Atom s diff --git a/src/ir_def/check_ir.ml b/src/ir_def/check_ir.ml index 0e1e14c363b..32cfa7e5a95 100644 --- a/src/ir_def/check_ir.ml +++ b/src/ir_def/check_ir.ml @@ -549,6 +549,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; kr] -> let (_, t1) = try T.as_async_sub s T.Non (T.normalize (typ a)) diff --git a/src/ir_def/construct.ml b/src/ir_def/construct.ml index b0e418a6899..8b31a3e9624 100644 --- a/src/ir_def/construct.ml +++ b/src/ir_def/construct.ml @@ -111,6 +111,7 @@ let primE prim es = | SystemCyclesAcceptPrim -> T.nat | DeserializePrim ts -> T.seq ts | DeserializeOptPrim ts -> T.Opt (T.seq ts) + | ICCyclesPrim -> T.(Opt (Obj (Object, [(* FIXME *)]))) | OtherPrim "trap" -> T.Non | OtherPrim "call_perform_status" -> T.(Prim Nat32) | OtherPrim "call_perform_message" -> T.text diff --git a/src/ir_def/ir.ml b/src/ir_def/ir.ml index d8cde38b9fe..3aa145b4037 100644 --- a/src/ir_def/ir.ml +++ b/src/ir_def/ir.ml @@ -156,6 +156,7 @@ and prim = | SystemCyclesAvailablePrim | SystemCyclesBalancePrim | SystemCyclesRefundedPrim + | ICCyclesPrim (* cycles to send by parenthetical *) | SetCertifiedData | GetCertificate @@ -297,6 +298,7 @@ let map_prim t_typ t_id t_exp p = | SystemCyclesAvailablePrim | SystemCyclesBalancePrim | SystemCyclesRefundedPrim + | ICCyclesPrim | SetCertifiedData | GetCertificate | OtherPrim _ -> p diff --git a/src/ir_passes/await.ml b/src/ir_passes/await.ml index 7ef19bdc480..6a1ce82bc65 100644 --- a/src/ir_passes/await.ml +++ b/src/ir_passes/await.ml @@ -75,6 +75,9 @@ let rec t_async context exp = cps_asyncE s typ1 (typ exp1) (forall [tb] ([k_ret; k_fail] -->* (c_exp context' exp1 (ContVar k_ret)))) + |> if s = Fut + then thenE (primE ICCyclesPrim []) + else fun e -> e | _ -> assert false (* Trivial translation of pure terms (eff = T.Triv) *) diff --git a/src/viper/trans.ml b/src/viper/trans.ml index b169b729c46..02725a17a9f 100644 --- a/src/viper/trans.ml +++ b/src/viper/trans.ml @@ -804,7 +804,7 @@ and assign_stmts ctxt at (lval : lvalue) (e : M.exp) : seqn' = match e with | M.({it=TupE [];_}) -> [], [] | M.({it=AnnotE (e, _);_}) -> assign_stmts ctxt at lval e - | M.({it=CallE ({it=M.DotE ({it=M.VarE(m);_}, {it="init";_});_}, _inst, args);_}) + | M.({it=CallE (_, {it=M.DotE ({it=M.VarE(m);_}, {it="init";_});_}, _inst, args);_}) when Imports.find_opt (m.it) ctxt.imports = Some(IM_base_Array) -> begin match args with @@ -818,7 +818,7 @@ and assign_stmts ctxt at (lval : lvalue) (e : M.exp) : seqn' = ) | _ -> unsupported args.at (Arrange.exp args) end - | M.({it = CallE({it = VarE m; _}, inst, args); _}) -> + | M.({it = CallE(_, {it = VarE m; _}, inst, args); _}) -> fld_via_tmp_var ctxt lval t (fun x -> let self_var = self ctxt m.at in [], [ !!(MethodCallS ([x], id m, self_var :: call_args ctxt args)) ]) @@ -879,7 +879,7 @@ and exp ctxt e = end | M.AnnotE(a, b) -> exp ctxt a - | M.CallE ({it=M.DotE (e1, {it="size";_});_}, _inst, {it=M.TupE ([]);at;_}) + | M.CallE (_, {it=M.DotE (e1, {it="size";_});_}, _inst, {it=M.TupE ([]);at;_}) -> sizeE at (exp ctxt e1) | M.LitE r -> begin match !r with @@ -960,7 +960,7 @@ and exp ctxt e = let n = List.length es in ctxt.reqs.tuple_arities := IntSet.add n !(ctxt.reqs.tuple_arities); !!(CallE (tup_con_name n, List.map (exp ctxt) es)) - | M.CallE ({ it = M.DotE ({it=M.VarE(m);_}, {it=predicate_name;_}); _ }, _inst, { it = M.FuncE (_, _, _, pattern, _, _, e); note; _ }) + | M.CallE (_, { it = M.DotE ({it=M.VarE(m);_}, {it=predicate_name;_}); _ }, _inst, { it = M.FuncE (_, _, _, pattern, _, _, e); note; _ }) when Imports.find_opt (m.it) ctxt.imports = Some(IM_Prim) && (predicate_name = "forall" || predicate_name = "exists") -> @@ -983,7 +983,7 @@ and exp ctxt e = | "forall" -> !!(ForallE (typed_binders, e)) | "exists" -> !!(ExistsE (typed_binders, e)) | _ -> assert false) - | M.CallE ({ it = M.DotE ({it=M.VarE(m);_}, {it="Ret";_}); _ }, _, _) + | M.CallE (_, { it = M.DotE ({it=M.VarE(m);_}, {it="Ret";_}); _ }, _, _) when Imports.find_opt (m.it) ctxt.imports = Some(IM_Prim) -> !!(FldE "$Res") | _ -> unsupported e.at (Arrange.exp e) diff --git a/src/viper/traversals.ml b/src/viper/traversals.ml index a21c99178a1..5a53985120a 100644 --- a/src/viper/traversals.ml +++ b/src/viper/traversals.ml @@ -36,7 +36,7 @@ let rec over_exp (v : visitor) (exp : exp) : exp = | IdxE (exp1, exp2) -> { exp with it = IdxE (over_exp v exp1, over_exp v exp2) } | RelE (x, exp1, y, exp2) -> { exp with it = RelE (x, over_exp v exp1, y, over_exp v exp2) } | AssignE (exp1, exp2) -> { exp with it = AssignE (over_exp v exp1, over_exp v exp2) } - | CallE (exp1, inst, exp2) -> { exp with it = CallE (over_exp v exp1, over_inst v inst, over_exp v exp2) } + | CallE (exp_opt, exp1, inst, exp2) -> { exp with it = CallE (Option.map (over_exp v) exp_opt, over_exp v exp1, over_inst v inst, over_exp v exp2) } | AndE (exp1, exp2) -> { exp with it = AndE (over_exp v exp1, over_exp v exp2) } | OrE (exp1, exp2) -> { exp with it = OrE (over_exp v exp1, over_exp v exp2) } | ImpliesE (exp1, exp2) -> { exp with it = ImpliesE (over_exp v exp1, over_exp v exp2) } diff --git a/test/run-drun/clone.mo b/test/run-drun/clone.mo index 1feaf4b5735..49bd06be244 100644 --- a/test/run-drun/clone.mo +++ b/test/run-drun/clone.mo @@ -1,3 +1,4 @@ +//MOC-FLAG -dl import Prim "mo:⛔"; import Cycles "cycles/cycles"; import Lib "clone/cloneable"; From 38dfd70cb3fb9aefd704df876b89a71a1f569811 Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Wed, 17 Jul 2024 23:09:44 +0200 Subject: [PATCH 029/127] WIP: `CPSAsync` --- src/ir_def/arrange_ir.ml | 4 ++-- src/ir_def/check_ir.ml | 2 +- src/ir_def/construct.ml | 16 ++++++++-------- src/ir_def/construct.mli | 2 +- src/ir_def/ir.ml | 4 ++-- src/ir_passes/async.ml | 8 ++++---- src/ir_passes/await.ml | 7 ++----- 7 files changed, 20 insertions(+), 23 deletions(-) diff --git a/src/ir_def/arrange_ir.ml b/src/ir_def/arrange_ir.ml index a950f3cb395..98c8f8b1053 100644 --- a/src/ir_def/arrange_ir.ml +++ b/src/ir_def/arrange_ir.ml @@ -104,8 +104,8 @@ and prim = function | 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" diff --git a/src/ir_def/check_ir.ml b/src/ir_def/check_ir.ml index 32cfa7e5a95..629a47efe02 100644 --- a/src/ir_def/check_ir.ml +++ b/src/ir_def/check_ir.ml @@ -572,7 +572,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(T.Local, T.Returns, [], ts1, []); diff --git a/src/ir_def/construct.ml b/src/ir_def/construct.ml index 8b31a3e9624..d69f27c4519 100644 --- a/src/ir_def/construct.ml +++ b/src/ir_def/construct.ml @@ -157,8 +157,14 @@ let awaitE s e = note = Note.{ def with typ; eff = T.Await } } -let cps_asyncE s typ1 typ2 e = - { it = PrimE (CPSAsync (s, typ1), [e]); +let nullE () = + { it = LitE NullLit; + at = no_region; + note = Note.{ def with typ = T.Prim T.Null } + } + +let cps_asyncE s typ1 par typ2 e = + { it = PrimE (CPSAsync (s, typ1, if s = Fut then par else nullE ()), [e]); at = no_region; note = Note.{ def with typ = T.Async (s, typ1, typ2); eff = eff e } } @@ -293,12 +299,6 @@ let boolE b = note = Note.{ def with typ = T.bool } } -let nullE () = - { it = LitE NullLit; - at = no_region; - note = Note.{ def with typ = T.Prim T.Null } - } - (* Functions *) diff --git a/src/ir_def/construct.mli b/src/ir_def/construct.mli index b7c961734d9..9e2ed3776f0 100644 --- a/src/ir_def/construct.mli +++ b/src/ir_def/construct.mli @@ -52,7 +52,7 @@ val selfRefE : typ -> exp val assertE : exp -> exp val asyncE : async_sort -> typ_bind -> exp -> typ -> exp val awaitE : async_sort -> exp -> exp -val cps_asyncE : async_sort -> typ -> typ -> exp -> exp +val cps_asyncE : async_sort -> typ -> exp -> typ -> exp -> exp val cps_awaitE : async_sort -> typ -> exp -> exp -> exp val ic_replyE : typ list -> exp -> exp val ic_rejectE : exp -> exp diff --git a/src/ir_def/ir.ml b/src/ir_def/ir.ml index 3aa145b4037..769e0125bad 100644 --- a/src/ir_def/ir.ml +++ b/src/ir_def/ir.ml @@ -164,7 +164,7 @@ and prim = (* backend stuff *) | CPSAwait of Type.async_sort * Type.typ (* typ is the current continuation type of cps translation *) - | CPSAsync of Type.async_sort * Type.typ + | CPSAsync of Type.async_sort * Type.typ * exp | ICPerformGC | ICReplyPrim of Type.typ list | ICRejectPrim @@ -303,7 +303,7 @@ let map_prim t_typ t_id t_exp p = | GetCertificate | OtherPrim _ -> p | CPSAwait (s, t) -> CPSAwait (s, t_typ t) - | CPSAsync (s, t) -> CPSAsync (s, t_typ t) + | CPSAsync (s, t, par) -> CPSAsync (s, t_typ t, t_exp par) | ICReplyPrim ts -> ICReplyPrim (List.map t_typ ts) | ICArgDataPrim | ICPerformGC diff --git a/src/ir_passes/async.ml b/src/ir_passes/async.ml index 864a3cef648..51464fa0906 100644 --- a/src/ir_passes/async.ml +++ b/src/ir_passes/async.ml @@ -268,7 +268,7 @@ let transform prog = ((t_exp a) -*- (t_exp kr)).it | _ -> assert false end - | PrimE (CPSAsync (Fut, t), [exp1]) -> + | PrimE (CPSAsync (Fut, t, _FIXME), [exp1]) -> let t0 = t_typ t in let tb, ts1 = match typ exp1 with | Func(_,_, [tb], [Func(_, _, [], ts1, []); _], []) -> @@ -290,7 +290,7 @@ let transform prog = ] (varE nary_async) ).it - | PrimE (CPSAsync (Cmp, t), [exp1]) -> + | PrimE (CPSAsync (Cmp, t, _), [exp1]) -> let t0 = t_typ t in let tb, t_ret, t_fail = match typ exp1 with | Func(_,_, [tb], [t_ret; t_fail], _ ) -> @@ -385,7 +385,7 @@ let transform prog = let args' = t_args args in let typbinds' = t_typ_binds typbinds in let t0, cps = match exp.it with - | PrimE (CPSAsync (Type.Fut, t0), [cps]) -> t_typ t0, cps + | PrimE (CPSAsync (Fut, t0, _FIXME), [cps]) -> t_typ t0, cps | _ -> assert false in let t1, contT = match typ cps with | Func (_,_, @@ -414,7 +414,7 @@ let transform prog = let args' = t_args args in let typbinds' = t_typ_binds typbinds in let t0, cps = match exp.it with - | PrimE (CPSAsync (Type.Fut, t0), [cps]) -> t_typ t0, cps (* TBR *) + | PrimE (CPSAsync (Fut, t0, _FIXME), [cps]) -> t_typ t0, cps (* TBR *) | _ -> assert false in let t1, contT = match typ cps with | Func (_, _, diff --git a/src/ir_passes/await.ml b/src/ir_passes/await.ml index 6a1ce82bc65..7b4af9a6e75 100644 --- a/src/ir_passes/await.ml +++ b/src/ir_passes/await.ml @@ -72,12 +72,9 @@ let rec t_async context exp = LabelEnv.add Return (Cont (ContVar k_ret)) (LabelEnv.add Throw (Cont (ContVar k_fail)) LabelEnv.empty) in - cps_asyncE s typ1 (typ exp1) + cps_asyncE s typ1 (primE ICCyclesPrim []) (typ exp1) (forall [tb] ([k_ret; k_fail] -->* (c_exp context' exp1 (ContVar k_ret)))) - |> if s = Fut - then thenE (primE ICCyclesPrim []) - else fun e -> e | _ -> assert false (* Trivial translation of pure terms (eff = T.Triv) *) @@ -406,7 +403,7 @@ and c_exp' context exp k = | None -> assert false in let cps_async = - cps_asyncE T.Fut typ1 (typ exp1) + cps_asyncE T.Fut typ1 (primE ICCyclesPrim []) (typ exp1) (forall [tb] ([k_ret; k_fail] -->* (c_exp context' exp1 (ContVar k_ret)))) in let k' = meta (typ cps_async) From 1f61bb578c7a59218e93f716442369bb2ef86a35 Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Thu, 18 Jul 2024 17:15:01 +0200 Subject: [PATCH 030/127] WIP: begin fleshing out receiving --- src/ir_passes/async.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/ir_passes/async.ml b/src/ir_passes/async.ml index 51464fa0906..d86edd93ecb 100644 --- a/src/ir_passes/async.ml +++ b/src/ir_passes/async.ml @@ -268,7 +268,7 @@ let transform prog = ((t_exp a) -*- (t_exp kr)).it | _ -> assert false end - | PrimE (CPSAsync (Fut, t, _FIXME), [exp1]) -> + | PrimE (CPSAsync (Fut, t, cyc), [exp1]) -> let t0 = t_typ t in let tb, ts1 = match typ exp1 with | Func(_,_, [tb], [Func(_, _, [], ts1, []); _], []) -> @@ -286,7 +286,7 @@ let transform prog = let e = fresh_var "e" T.catch in e --> (ic_rejectE (errorMessageE (varE e))) in let exp' = callE (t_exp exp1) [t0] (tupE [ic_reply; ic_reject]) in - expD (selfcallE ts1 exp' (varE nary_reply) (varE reject)) + expD (selfcallE ts1 exp' (varE nary_reply) (varE reject) |> thenE cyc) ] (varE nary_async) ).it From 4d0d26345b643733407976b144335385c3b8a44c Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Thu, 18 Jul 2024 18:26:40 +0200 Subject: [PATCH 031/127] WIP: draft codegen for `ICCyclesPrim` --- src/codegen/compile.ml | 13 ++++++++++--- 1 file changed, 10 insertions(+), 3 deletions(-) diff --git a/src/codegen/compile.ml b/src/codegen/compile.ml index b81b662c703..21b7caf0b56 100644 --- a/src/codegen/compile.ml +++ b/src/codegen/compile.ml @@ -2406,12 +2406,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] ] ) ) @@ -11850,6 +11851,12 @@ 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, + Opt.(inject_simple env (G.i (LocalGet (nr 0l))) ^^ + null_lit env) ^^ + G.i (LocalGet (nr 0l)) ^^ + G.i Select | SetCertifiedData, [e1] -> SR.unit, compile_exp_vanilla env ae e1 ^^ IC.set_certified_data env From d472f53741a1b23c834dba559f27c0095459392a Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Thu, 18 Jul 2024 22:57:43 +0200 Subject: [PATCH 032/127] WIP: yes, it expodes! --- src/codegen/compile.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/codegen/compile.ml b/src/codegen/compile.ml index 21b7caf0b56..786b1b98355 100644 --- a/src/codegen/compile.ml +++ b/src/codegen/compile.ml @@ -10577,7 +10577,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 @@ -10622,7 +10622,7 @@ and compile_prim_invocation (env : E.t) ae p es at = StackRep.of_arity return_arity, code1 ^^ - compile_unboxed_zero ^^ (* A dummy closure *) + (assert (Type.as_obj par.note.typ = (Object, []));compile_unboxed_zero) ^^ (* A dummy closure *) 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) From 48096cb4eebef146409422c46fd365b490bdb038 Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Thu, 18 Jul 2024 23:07:17 +0200 Subject: [PATCH 033/127] actually send the parenthetical --- src/codegen/compile.ml | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/codegen/compile.ml b/src/codegen/compile.ml index 786b1b98355..2bdc1e56760 100644 --- a/src/codegen/compile.ml +++ b/src/codegen/compile.ml @@ -10622,7 +10622,9 @@ and compile_prim_invocation (env : E.t) ae p es at = StackRep.of_arity return_arity, code1 ^^ - (assert (Type.as_obj par.note.typ = (Object, []));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) From ff217f360482822b5b784933d4066537ac7a30c1 Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Fri, 19 Jul 2024 05:52:51 +0200 Subject: [PATCH 034/127] tweak --- src/ir_passes/await.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/ir_passes/await.ml b/src/ir_passes/await.ml index 7b4af9a6e75..585c35fa463 100644 --- a/src/ir_passes/await.ml +++ b/src/ir_passes/await.ml @@ -218,7 +218,7 @@ and binary context k binE e1 e2 = assert false and nary context k naryE es = - let rec nary_aux vs es = + let rec nary_aux vs es = match es with | [] -> k -@- naryE (List.rev vs) | [e1] when eff e1 = T.Triv -> From 29110d3f2090ac271e0035edd8cfee03aafbb96d Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Fri, 19 Jul 2024 06:12:11 +0200 Subject: [PATCH 035/127] interpret `ICCallerPrim` as non-informative --- src/ir_interpreter/interpret_ir.ml | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/ir_interpreter/interpret_ir.ml b/src/ir_interpreter/interpret_ir.ml index 0bd0093c619..8d90831d079 100644 --- a/src/ir_interpreter/interpret_ir.ml +++ b/src/ir_interpreter/interpret_ir.ml @@ -453,6 +453,8 @@ and interpret_exp_mut env exp (k : V.value V.cont) = last_region := exp.at; (* in case the following throws *) let vc = context env in f (V.Tup[vc; kv; rv]) v2 k + | ICCyclesPrim, [] -> + k V.Null | ICCallerPrim, [] -> k env.caller | ICStableRead t, [] -> From 4abc9e8c83d8372bf343107cd189e126a37738d3 Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Tue, 30 Jul 2024 12:20:49 +0200 Subject: [PATCH 036/127] WIP: pass a pair when there is a closure. The first component is the parenthetical record and the second is the closure environment for the call. --- src/codegen/compile.ml | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/src/codegen/compile.ml b/src/codegen/compile.ml index 3819e8c80c2..45b57da00cc 100644 --- a/src/codegen/compile.ml +++ b/src/codegen/compile.ml @@ -2536,7 +2536,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)) ^^ @@ -10638,9 +10638,11 @@ 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 with + | Object, [] -> get_clos (* just the closure *) + | _ -> Arr.lit env [compile_exp_vanilla env ae par; get_clos]) ^^ (* parenthetical: pass a pair *) compile_exp_as env ae (StackRep.of_arity n_args) e2 ^^ get_clos ^^ Closure.call_closure env n_args return_arity From 261ae02d658bf2da3a7bb31f7eaf0a3060891414 Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Mon, 5 Aug 2024 12:27:56 +0200 Subject: [PATCH 037/127] simplify --- src/lowering/desugar.ml | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/lowering/desugar.ml b/src/lowering/desugar.ml index bd57d740161..648003f60df 100644 --- a/src/lowering/desugar.ml +++ b/src/lowering/desugar.ml @@ -24,11 +24,11 @@ let id_of_full_path (fp : string) : string = let apply_sign op l = Syntax.(match op, l with | PosOp, l -> l - | NegOp, (NatLit n | IntLit n) -> IntLit (Numerics.Int.sub Numerics.Int.zero n) - | NegOp, Int8Lit n -> Int8Lit (Numerics.Int_8.sub Numerics.Int_8.zero n) - | NegOp, Int16Lit n -> Int16Lit (Numerics.Int_16.sub Numerics.Int_16.zero n) - | NegOp, Int32Lit n -> Int32Lit (Numerics.Int_32.sub Numerics.Int_32.zero n) - | NegOp, Int64Lit n -> Int64Lit (Numerics.Int_64.sub Numerics.Int_64.zero n) + | NegOp, (NatLit n | IntLit n) -> IntLit Numerics.Int.(sub zero n) + | NegOp, Int8Lit n -> Int8Lit Numerics.Int_8.(sub zero n) + | NegOp, Int16Lit n -> Int16Lit Numerics.Int_16.(sub zero n) + | NegOp, Int32Lit n -> Int32Lit Numerics.Int_32.(sub zero n) + | NegOp, Int64Lit n -> Int64Lit Numerics.Int_64.(sub zero n) | _, _ -> raise (Invalid_argument "Invalid signed pattern") ) From 2e5b78769696f75ea1583834e3064f1c0ce60ef0 Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Mon, 5 Aug 2024 13:27:26 +0200 Subject: [PATCH 038/127] restrict pair creation --- src/codegen/compile.ml | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/src/codegen/compile.ml b/src/codegen/compile.ml index 45b57da00cc..8b27036a637 100644 --- a/src/codegen/compile.ml +++ b/src/codegen/compile.ml @@ -10640,9 +10640,10 @@ and compile_prim_invocation (env : E.t) ae p es at = code1 ^^ StackRep.adjust env fun_sr SR.Vanilla ^^ Closure.prepare_closure_call env ^^ (* FIXME: move to front elsewhere too *) set_clos ^^ - Type.(match as_obj par.note.Note.typ with - | Object, [] -> get_clos (* just the closure *) - | _ -> Arr.lit env [compile_exp_vanilla env ae par; get_clos]) ^^ (* parenthetical: pass a pair *) + Type.(match as_obj par.note.Note.typ, ret_tys with + | (Object, []), _ -> get_clos (* just the closure *) + | _, [ret] when is_async ret -> Arr.lit env [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 From 8c056503b80adf2c3c5db7f23ff2cfe001ffc0d8 Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Mon, 5 Aug 2024 13:34:27 +0200 Subject: [PATCH 039/127] futures only --- src/codegen/compile.ml | 2 +- src/mo_types/type.ml | 2 ++ src/mo_types/type.mli | 2 ++ 3 files changed, 5 insertions(+), 1 deletion(-) diff --git a/src/codegen/compile.ml b/src/codegen/compile.ml index 8b27036a637..e7fecd56d73 100644 --- a/src/codegen/compile.ml +++ b/src/codegen/compile.ml @@ -10642,7 +10642,7 @@ and compile_prim_invocation (env : E.t) ae p es at = set_clos ^^ Type.(match as_obj par.note.Note.typ, ret_tys with | (Object, []), _ -> get_clos (* just the closure *) - | _, [ret] when is_async ret -> Arr.lit env [compile_exp_vanilla env ae par; get_clos] (* parenthetical: pass a pair *) + | _, [ret] when is_async_fut ret -> Arr.lit env [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 ^^ diff --git a/src/mo_types/type.ml b/src/mo_types/type.ml index 0adef07bca2..cf65f15930c 100644 --- a/src/mo_types/type.ml +++ b/src/mo_types/type.ml @@ -580,6 +580,8 @@ let is_unit = function Tup [] -> true | _ -> false let is_pair = function Tup [_; _] -> true | _ -> false let is_func = function Func _ -> true | _ -> false let is_async = function Async _ -> true | _ -> false +let is_async_cmp = function Async (Cmp, _, _) -> true | _ -> false +let is_async_fut = function Async (Fut, _, _) -> true | _ -> false let is_mut = function Mut _ -> true | _ -> false let is_typ = function Typ _ -> true | _ -> false let is_con = function Con _ -> true | _ -> false diff --git a/src/mo_types/type.mli b/src/mo_types/type.mli index a90889ffefb..5bfcc82d761 100644 --- a/src/mo_types/type.mli +++ b/src/mo_types/type.mli @@ -129,6 +129,8 @@ val is_unit : typ -> bool val is_pair : typ -> bool val is_func : typ -> bool val is_async : typ -> bool +val is_async_cmp : typ -> bool +val is_async_fut : typ -> bool val is_mut : typ -> bool val is_typ : typ -> bool val is_con : typ -> bool From f9abea41986c391e7ddbdce5324ff01f52250d5e Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Mon, 5 Aug 2024 14:50:22 +0200 Subject: [PATCH 040/127] simplifying folds --- src/ir_def/construct.ml | 14 +++++++------- src/ir_def/ir_effect.ml | 16 +++++++++------- src/ir_def/ir_effect.mli | 4 ++++ src/mo_frontend/effect.ml | 4 ++-- 4 files changed, 22 insertions(+), 16 deletions(-) diff --git a/src/ir_def/construct.ml b/src/ir_def/construct.ml index 50bf6c33de1..338a56708f2 100644 --- a/src/ir_def/construct.ml +++ b/src/ir_def/construct.ml @@ -121,7 +121,7 @@ let primE prim es = | OtherPrim "is_controller" -> T.bool | _ -> assert false (* implement more as needed *) in - let eff = List.(map eff es |> fold_left max_eff T.Triv) in + let eff = map_max_effs eff es in { it = PrimE (prim, es); at = no_region; note = Note.{ def with typ; eff } @@ -194,7 +194,7 @@ let ic_rejectE e = let ic_callE s f e k r c = let es = [f; e; k; r; c] in - let eff = List.(map eff es |> fold_left max_eff T.Triv) in + let eff = map_max_effs eff es in { it = PrimE (ICCallPrim s, es); at = no_region; note = Note.{ def with typ = T.unit; eff } @@ -202,7 +202,7 @@ let ic_callE s f e k r c = let ic_call_rawE p m a k r c = let es = [p; m; a; k; r; c] in - let eff = List.(map eff es |> fold_left max_eff T.Triv) in + let eff = map_max_effs eff es in { it = PrimE (ICCallRawPrim, es); at = no_region; note = Note.{ def with typ = T.unit; eff } @@ -253,7 +253,7 @@ let blockE decs exp = | [] -> exp | _ -> let typ = typ exp in - let eff = List.(map dec_eff decs' |> fold_left max_eff (eff exp)) in + let eff = map_max_effs' (eff exp) dec_eff decs' in { it = BlockE (decs', exp); at = no_region; note = Note.{ def with typ; eff } @@ -414,7 +414,7 @@ let switch_variantE exp1 cases typ1 = at = no_region; note = Note.{ def with typ = typ1; - eff = List.(map (fun (l,p,e) -> eff e) cases |> fold_left max_eff (eff exp1)) + eff = map_max_effs' (eff exp1) (fun (_, _, e) -> eff e) cases } } @@ -438,13 +438,13 @@ let switch_textE exp1 cases (pat, exp2) typ1 = note = Note.{ def with typ = typ1; - eff = List.(map (fun c -> eff c.it.exp) cs |> fold_left max_eff (eff exp1)) + eff = map_max_effs' (eff exp1) (fun c -> eff c.it.exp) cs } } let tupE exps = - let eff = List.(map eff exps |> fold_left max_eff T.Triv) in + let eff = map_max_effs eff exps in { it = PrimE (TupPrim, exps); at = no_region; note = Note.{ def with typ = T.Tup (List.map typ exps); eff }; diff --git a/src/ir_def/ir_effect.ml b/src/ir_def/ir_effect.ml index 32f86094cd8..a92185514b3 100644 --- a/src/ir_def/ir_effect.ml +++ b/src/ir_def/ir_effect.ml @@ -8,11 +8,16 @@ module T = Mo_types.Type but I prefer to keep it mostly separate for now *) let max_eff e1 e2 = - match e1,e2 with + match e1, e2 with | T.Triv, T.Triv -> T.Triv | _ , T.Await -> T.Await | T.Await, _ -> T.Await +let max_effs' seed = List.fold_left max_eff seed +let max_effs es = max_effs' T.Triv es +let map_max_effs' seed f l = max_effs' seed (List.map f l) +let map_max_effs f l = map_max_effs' T.Triv f l + let typ phrase = phrase.note.Note.typ let eff phrase = phrase.note.Note.eff @@ -40,7 +45,7 @@ let rec infer_effect_prim p exps = if is_async_call p exps then T.Await else - List.fold_left max_eff T.Triv (List.map eff exps) + map_max_effs eff exps and infer_effect_exp (exp: exp) : T.eff = match exp.it with @@ -54,8 +59,7 @@ and infer_effect_exp (exp: exp) : T.eff = | PrimE (p, exps) -> infer_effect_prim p exps | BlockE (ds, exp) -> - let es = List.map effect_dec ds in - List.fold_left max_eff (effect_exp exp) es + map_max_effs' (effect_exp exp) effect_dec ds | IfE (exp1, exp2, exp3) -> let e1 = effect_exp exp1 in let e2 = effect_exp exp2 in @@ -102,6 +106,4 @@ and effect_dec dec = match dec.it with let infer_effect_dec = effect_dec -let infer_effect_decs ds = - let es = List.map effect_dec ds in - List.fold_left max_eff T.Triv es +let infer_effect_decs = map_max_effs effect_dec diff --git a/src/ir_def/ir_effect.mli b/src/ir_def/ir_effect.mli index 02ac7dd0d7b..f77a2b43fdc 100644 --- a/src/ir_def/ir_effect.mli +++ b/src/ir_def/ir_effect.mli @@ -4,6 +4,10 @@ open Mo_types.Type val is_async_call : Ir.prim -> Ir.exp list -> bool val max_eff : eff -> eff -> eff +val max_effs : eff list -> eff +val max_effs' : eff -> eff list -> eff +val map_max_effs : ('a -> eff) -> 'a list -> eff +val map_max_effs' : eff -> ('a -> eff) -> 'a list -> eff (* (incremental) effect inference on IR *) diff --git a/src/mo_frontend/effect.ml b/src/mo_frontend/effect.ml index aa05f3a6424..50d93296d18 100644 --- a/src/mo_frontend/effect.ml +++ b/src/mo_frontend/effect.ml @@ -129,10 +129,10 @@ and effect_cases cases = max_eff e (effect_cases cases') and infer_effect_dec_fields dfs = - List.fold_left (fun e (df : dec_field) -> max_eff e (effect_dec df.it.dec)) T.Triv dfs + map_max_effs (fun (df : dec_field) -> effect_dec df.it.dec) dfs and infer_effect_exp_fields efs = - List.fold_left (fun e (ef : exp_field) -> max_eff e (effect_exp ef.it.exp)) T.Triv efs + map_max_effs (fun (ef : exp_field) -> effect_exp ef.it.exp) efs and effect_dec dec = dec.note.note_eff From 998f689d993fe9d3e05704138188e1114d8f0be7 Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Mon, 5 Aug 2024 20:49:05 +0200 Subject: [PATCH 041/127] WIP: prepare `ICCyclesPrim` for all possibilities --- src/codegen/compile.ml | 22 ++++++++++++++++++---- 1 file changed, 18 insertions(+), 4 deletions(-) diff --git a/src/codegen/compile.ml b/src/codegen/compile.ml index e7fecd56d73..635d21688e9 100644 --- a/src/codegen/compile.ml +++ b/src/codegen/compile.ml @@ -11867,10 +11867,24 @@ and compile_prim_invocation (env : E.t) ae p es at = SR.Vanilla, Cycles.refunded env | ICCyclesPrim, [] -> SR.Vanilla, - Opt.(inject_simple env (G.i (LocalGet (nr 0l))) ^^ - null_lit env) ^^ - G.i (LocalGet (nr 0l)) ^^ - G.i Select + 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, + 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) | SetCertifiedData, [e1] -> SR.unit, compile_exp_vanilla env ae e1 ^^ IC.set_certified_data env From 6873747ec39567c4e9428470cac49f2cdcb832ee Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Mon, 5 Aug 2024 21:14:27 +0200 Subject: [PATCH 042/127] tweak --- src/codegen/compile.ml | 28 ++++++++++++---------------- 1 file changed, 12 insertions(+), 16 deletions(-) diff --git a/src/codegen/compile.ml b/src/codegen/compile.ml index 635d21688e9..b12b607c583 100644 --- a/src/codegen/compile.ml +++ b/src/codegen/compile.ml @@ -2213,31 +2213,27 @@ module Tagged = struct match (tag : tag) with | Region -> begin match normalize ty with - | (Con _ | Any) -> true - | (Prim Region) -> true - | (Prim _ | Obj _ | Array _ | Tup _ | Opt _ | Variant _ | Func _ | Non) -> false - | (Pre | Async _ | Mut _ | Var _ | Typ _) -> assert false + | Con _ | Any | Prim Region -> true + | Prim _ | Obj _ | Array _ | Tup _ | Opt _ | Variant _ | Func _ | Non -> false + | Pre | Async _ | Mut _ | Var _ | Typ _ -> assert false end | Array -> begin match normalize ty with - | (Con _ | Any) -> true - | (Array _ | Tup _) -> true - | (Prim _ | Obj _ | Opt _ | Variant _ | Func _ | Non) -> false - | (Pre | Async _ | Mut _ | Var _ | Typ _) -> assert false + | Con _ | Any | Array _ | Tup _ -> true + | Prim _ | Obj _ | Opt _ | Variant _ | Func _ | Non -> false + | Pre | Async _ | Mut _ | Var _ | Typ _ -> assert false end | Blob -> begin match normalize ty with - | (Con _ | Any) -> true - | (Prim (Text|Blob|Principal)) -> true - | (Prim _ | Obj _ | Array _ | Tup _ | Opt _ | Variant _ | Func _ | Non) -> false - | (Pre | Async _ | Mut _ | Var _ | Typ _) -> assert false + | Con _ | Any | Prim (Text | Blob | Principal) -> true + | Prim _ | Obj _ | Array _ | Tup _ | Opt _ | Variant _ | Func _ | Non -> false + | Pre | Async _ | Mut _ | Var _ | Typ _ -> assert false end | Object -> begin match normalize ty with - | (Con _ | Any) -> true - | (Obj _) -> true - | (Prim _ | Array _ | Tup _ | Opt _ | Variant _ | Func _ | Non) -> false - | (Pre | Async _ | Mut _ | Var _ | Typ _) -> assert false + | Con _ | Any | Obj _ -> true + | Prim _ | Array _ | Tup _ | Opt _ | Variant _ | Func _ | Non -> false + | Pre | Async _ | Mut _ | Var _ | Typ _ -> assert false end | _ -> true From 3f4c1de51c1068fda24b89152960876ca8663d1d Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Mon, 5 Aug 2024 21:18:44 +0200 Subject: [PATCH 043/127] tweak --- src/ir_passes/async.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/ir_passes/async.ml b/src/ir_passes/async.ml index 06100c7145b..297a223fb92 100644 --- a/src/ir_passes/async.ml +++ b/src/ir_passes/async.ml @@ -251,7 +251,7 @@ let transform prog = at = exp.at; } - and t_prim p = Ir.map_prim t_typ (fun id -> id) t_exp p + and t_prim p = Ir.map_prim t_typ Fun.id t_exp p and t_exp' (exp:exp) = let exp' = exp.it in From 009f05d4d1bc5249cf5f09522d73d0dad99dfe0e Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Mon, 5 Aug 2024 21:26:16 +0200 Subject: [PATCH 044/127] tweak --- src/ir_def/construct.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/ir_def/construct.ml b/src/ir_def/construct.ml index 338a56708f2..95ba94537ed 100644 --- a/src/ir_def/construct.ml +++ b/src/ir_def/construct.ml @@ -159,7 +159,7 @@ let awaitE s e = let nullE () = { it = LitE NullLit; at = no_region; - note = Note.{ def with typ = T.Prim T.Null } + note = Note.{ def with typ = T.(Prim Null) } } let cps_asyncE s typ1 par typ2 e = From 2bbe8d5148a3767085218bb4db1ae3e41e9df896 Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Tue, 6 Aug 2024 11:15:15 +0200 Subject: [PATCH 045/127] WIP: this ccompiles --- src/codegen/compile.ml | 2 +- src/ir_def/arrange_ir.ml | 2 +- src/ir_def/check_ir.ml | 2 +- src/ir_def/freevars.ml | 2 +- src/ir_def/ir.ml | 2 +- src/ir_def/ir_effect.ml | 2 +- src/ir_def/rename.ml | 4 ++-- src/ir_interpreter/interpret_ir.ml | 2 +- src/ir_passes/async.ml | 8 ++++---- src/ir_passes/const.ml | 2 +- src/ir_passes/eq.ml | 4 ++-- src/ir_passes/show.ml | 4 ++-- src/ir_passes/tailcall.ml | 4 ++-- 13 files changed, 20 insertions(+), 20 deletions(-) diff --git a/src/codegen/compile.ml b/src/codegen/compile.ml index b12b607c583..78bbb93e7aa 100644 --- a/src/codegen/compile.ml +++ b/src/codegen/compile.ml @@ -12054,7 +12054,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, 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 diff --git a/src/ir_def/arrange_ir.ml b/src/ir_def/arrange_ir.ml index dae8347dd3f..7a545072887 100644 --- a/src/ir_def/arrange_ir.ml +++ b/src/ir_def/arrange_ir.ml @@ -28,7 +28,7 @@ let rec exp e = match e.it with | 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 (_FIXME, 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] | 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]) diff --git a/src/ir_def/check_ir.ml b/src/ir_def/check_ir.ml index 9e970535351..560fa116282 100644 --- a/src/ir_def/check_ir.ml +++ b/src/ir_def/check_ir.ml @@ -803,7 +803,7 @@ 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 (_FIXME, ts, exp_f, exp_k, exp_r, exp_c) -> check (not env.flavor.Ir.has_async_typ) "SelfCallE in async flavor"; List.iter (check_typ env) ts; check_exp { env with lvl = NotTopLvl } exp_f; diff --git a/src/ir_def/freevars.ml b/src/ir_def/freevars.ml index 36abdb6fe0a..7c04f5917ac 100644 --- a/src/ir_def/freevars.ml +++ b/src/ir_def/freevars.ml @@ -119,7 +119,7 @@ let rec exp e : f = match e.it with | ActorE (ds, fs, u, _) -> actor ds fs u | NewObjE (_, fs, _) -> fields fs | TryE (e, cs, cl) -> exp e ++ cases cs ++ (match cl with Some (v, _) -> id v | _ -> M.empty) - | SelfCallE (_, e1, e2, e3, e4) -> under_lambda (exp e1) ++ exps [e2; e3; e4] + | SelfCallE (_FIXME, _, e1, e2, e3, e4) -> under_lambda (exp e1) ++ exps [e2; e3; e4] and actor ds fs u = close (decs ds +++ fields fs +++ system u) diff --git a/src/ir_def/ir.ml b/src/ir_def/ir.ml index ecf11431163..9bdfd4ebcb5 100644 --- a/src/ir_def/ir.ml +++ b/src/ir_def/ir.ml @@ -71,7 +71,7 @@ and exp' = | DefineE of id * mut * exp (* promise fulfillment *) | FuncE of (* function *) string * Type.func_sort * Type.control * typ_bind list * arg list * Type.typ list * exp - | SelfCallE of Type.typ list * exp * exp * exp * exp (* essentially ICCallPrim (FuncE shared…) *) + | SelfCallE of exp * Type.typ list * exp * exp * exp * exp (* essentially ICCallPrim (FuncE shared…) *) | ActorE of dec list * field list * system * Type.typ (* actor *) | NewObjE of Type.obj_sort * field list * Type.typ (* make an object *) | TryE of exp * case list * (id * Type.typ) option (* try/catch/cleanup *) diff --git a/src/ir_def/ir_effect.ml b/src/ir_def/ir_effect.ml index a92185514b3..435e77257ed 100644 --- a/src/ir_def/ir_effect.ml +++ b/src/ir_def/ir_effect.ml @@ -81,7 +81,7 @@ and infer_effect_exp (exp: exp) : T.eff = effect_exp exp1 | FuncE _ -> T.Triv - | SelfCallE (_, _, exp1, exp2, exp3) -> + | SelfCallE (_FIXME, _, _, exp1, exp2, exp3) -> let e1 = effect_exp exp1 in let e2 = effect_exp exp2 in let e3 = effect_exp exp3 in diff --git a/src/ir_def/rename.ml b/src/ir_def/rename.ml index 3954ea4f532..d3b7d32c30b 100644 --- a/src/ir_def/rename.ml +++ b/src/ir_def/rename.ml @@ -64,8 +64,8 @@ and exp' rho = function FuncE (x, s, c, tp, p', ts, e') | NewObjE (s, fs, t) -> NewObjE (s, fields rho fs, t) | TryE (e, cs, cl) -> TryE (exp rho e, cases rho cs, Option.map (fun (v, t) -> id rho v, t) cl) - | SelfCallE (ts, e1, e2, e3, e4) -> - SelfCallE (ts, exp rho e1, exp rho e2, exp rho e3, exp rho e4) + | SelfCallE (_FIXME, ts, e1, e2, e3, e4) -> + SelfCallE (_FIXME, ts, exp rho e1, exp rho e2, exp rho e3, exp rho e4) and lexp rho le = {le with it = lexp' rho le.it} and lexp' rho = function diff --git a/src/ir_interpreter/interpret_ir.ml b/src/ir_interpreter/interpret_ir.ml index 17ae1809ec5..c3effe26d4d 100644 --- a/src/ir_interpreter/interpret_ir.ml +++ b/src/ir_interpreter/interpret_ir.ml @@ -538,7 +538,7 @@ and interpret_exp_mut env exp (k : V.value V.cont) = define_id env id v'; k V.unit ) - | SelfCallE (ts, exp_f, exp_k, exp_r, exp_c) -> + | SelfCallE (_FIXME, ts, exp_f, exp_k, exp_r, exp_c) -> assert (not env.flavor.has_async_typ); (* see code for FuncE *) let cc = { sort = T.Shared T.Write; control = T.Replies; n_args = 0; n_res = List.length ts } in diff --git a/src/ir_passes/async.ml b/src/ir_passes/async.ml index 297a223fb92..74e8771dfdf 100644 --- a/src/ir_passes/async.ml +++ b/src/ir_passes/async.ml @@ -24,8 +24,8 @@ module ConRenaming = E.Make(struct type t = con let compare = Cons.compare end) (* Helpers *) -let selfcallE ts e1 e2 e3 e4 = - { it = SelfCallE (ts, e1, e2, e3, e4); +let selfcallE (cyc : exp) ts e1 e2 e3 e4 = + { it = SelfCallE (cyc, ts, e1, e2, e3, e4); at = no_region; note = Note.{ def with typ = unit } } @@ -273,7 +273,7 @@ let transform prog = (* try await async (); schedule() catch e -> r(e) *) (let v = fresh_var "call" unit in letE v - (selfcallE [] (ic_replyE [] (unitE())) (varE schedule) (projE (varE vkrb) 1) + (selfcallE (recordE []) [] (ic_replyE [] (unitE())) (varE schedule) (projE (varE vkrb) 1) ([] -->* (projE (varE vkrb) 2 -*- unitE ()))) (check_call_perform_status (varE v) (fun e -> projE (varE vkrb) 1 -*- e)))) ] @@ -306,7 +306,7 @@ let transform prog = e --> ic_rejectE (errorMessageE (varE e)) in let ic_cleanup = varE (var "@cleanup" clean_contT) in let exp' = callE (t_exp exp1) [t0] (tupE [ic_reply; ic_reject; ic_cleanup]) in - expD (selfcallE ts1 exp' (varE nary_reply) (varE reject) (varE clean) |> thenE cyc) + expD (selfcallE cyc ts1 exp' (varE nary_reply) (varE reject) (varE clean)) ] (varE nary_async) ).it diff --git a/src/ir_passes/const.ml b/src/ir_passes/const.ml index 80f8389a5a6..cb56fcacbf9 100644 --- a/src/ir_passes/const.ml +++ b/src/ir_passes/const.ml @@ -147,7 +147,7 @@ let rec exp lvl (env : env) e : Lbool.t = exp_ lvl env e2; exp_ lvl env e3; surely_false - | SelfCallE (_, e1, e2, e3, e4) -> + | SelfCallE (_FIXME, _, e1, e2, e3, e4) -> exp_ NotTopLvl env e1; exp_ lvl env e2; exp_ lvl env e3; diff --git a/src/ir_passes/eq.ml b/src/ir_passes/eq.ml index fe2c907e841..6e1bff11e5d 100644 --- a/src/ir_passes/eq.ml +++ b/src/ir_passes/eq.ml @@ -248,8 +248,8 @@ and t_exp' env = function DefineE (id, mut, t_exp env exp1) | NewObjE (sort, ids, t) -> NewObjE (sort, ids, t) - | SelfCallE (ts, e1, e2, e3, e4) -> - SelfCallE (ts, t_exp env e1, t_exp env e2, t_exp env e3, t_exp env e4) + | SelfCallE (cyc, ts, e1, e2, e3, e4) -> + SelfCallE (t_exp env cyc, ts, t_exp env e1, t_exp env e2, t_exp env e3, t_exp env e4) | ActorE (ds, fields, {meta; preupgrade; postupgrade; heartbeat; timer; inspect}, typ) -> (* Until Actor expressions become their own units, we repeat what we do in `comp_unit` below *) diff --git a/src/ir_passes/show.ml b/src/ir_passes/show.ml index 379899ec0c3..38cb8583e61 100644 --- a/src/ir_passes/show.ml +++ b/src/ir_passes/show.ml @@ -290,8 +290,8 @@ and t_exp' env = function DefineE (id, mut, t_exp env exp1) | NewObjE (sort, ids, t) -> NewObjE (sort, ids, t) - | SelfCallE (ts, e1, e2, e3, e4) -> - SelfCallE (ts, t_exp env e1, t_exp env e2, t_exp env e3, t_exp env e4) + | SelfCallE (cyc, ts, e1, e2, e3, e4) -> + SelfCallE (t_exp env cyc, ts, t_exp env e1, t_exp env e2, t_exp env e3, t_exp env e4) | ActorE (ds, fields, {meta; preupgrade; postupgrade; heartbeat; timer; inspect}, typ) -> (* Until Actor expressions become their own units, we repeat what we do in `comp_unit` below *) diff --git a/src/ir_passes/tailcall.ml b/src/ir_passes/tailcall.ml index 32859d2b300..029c16ae2b9 100644 --- a/src/ir_passes/tailcall.ml +++ b/src/ir_passes/tailcall.ml @@ -120,13 +120,13 @@ and exp' env e : exp' = match e.it with let env2 = args env1 as_ in let exp0' = tailexp env2 exp0 in FuncE (x, s, c, tbs, as_, ret_tys, exp0') - | SelfCallE (ts, exp1, exp2, exp3, exp4) -> + | SelfCallE (_FIXME, ts, exp1, exp2, exp3, exp4) -> let env1 = { tail_pos = true; info = None} in let exp1' = tailexp env1 exp1 in let exp2' = exp env exp2 in let exp3' = exp env exp3 in let exp4' = exp env exp4 in - SelfCallE (ts, exp1', exp2', exp3', exp4') + SelfCallE (_FIXME, ts, exp1', exp2', exp3', exp4') | ActorE (ds, fs, u, t) -> let u = { u with preupgrade = exp env u.preupgrade; postupgrade = exp env u.postupgrade } in ActorE (snd (decs env ds), fs, u, t) From 391fedd064c7d72d983076c2dc5740efd630fb8f Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Tue, 6 Aug 2024 11:16:34 +0200 Subject: [PATCH 046/127] fix --- src/ir_passes/async.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/ir_passes/async.ml b/src/ir_passes/async.ml index 74e8771dfdf..bf5bc0bc9c6 100644 --- a/src/ir_passes/async.ml +++ b/src/ir_passes/async.ml @@ -273,7 +273,7 @@ let transform prog = (* try await async (); schedule() catch e -> r(e) *) (let v = fresh_var "call" unit in letE v - (selfcallE (recordE []) [] (ic_replyE [] (unitE())) (varE schedule) (projE (varE vkrb) 1) + (selfcallE ((*FIXME: what here? *) nullE ()) [] (ic_replyE [] (unitE())) (varE schedule) (projE (varE vkrb) 1) ([] -->* (projE (varE vkrb) 2 -*- unitE ()))) (check_call_perform_status (varE v) (fun e -> projE (varE vkrb) 1 -*- e)))) ] From 275e952cb3062946247722c13c7610966db878b6 Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Tue, 6 Aug 2024 12:04:19 +0200 Subject: [PATCH 047/127] wip --- src/ir_def/check_ir.ml | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/ir_def/check_ir.ml b/src/ir_def/check_ir.ml index 560fa116282..3bd46109588 100644 --- a/src/ir_def/check_ir.ml +++ b/src/ir_def/check_ir.ml @@ -805,11 +805,13 @@ let rec check_exp env (exp:Ir.exp) : unit = fun_ty <: t | SelfCallE (_FIXME, ts, exp_f, exp_k, exp_r, exp_c) -> check (not env.flavor.Ir.has_async_typ) "SelfCallE in async flavor"; + check_exp env _FIXME; 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; + (* TODO: cycles must be ?{ cycles : Nat } *) typ exp_f <: T.unit; typ exp_k <: T.(Construct.contT (Tup ts) unit); typ exp_r <: T.(Construct.err_contT unit); From 56d79fe8473244703187a7bcfe59d3d736f91ecf Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Tue, 6 Aug 2024 12:42:40 +0200 Subject: [PATCH 048/127] impl. type-checking --- src/ir_def/check_ir.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/ir_def/check_ir.ml b/src/ir_def/check_ir.ml index 3bd46109588..1012f2e6ae1 100644 --- a/src/ir_def/check_ir.ml +++ b/src/ir_def/check_ir.ml @@ -803,15 +803,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 (_FIXME, 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 _FIXME; + 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; - (* TODO: cycles must be ?{ cycles : Nat } *) + 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); From 40099822a3ac46c6e1760bf328839129694d5c1f Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Tue, 6 Aug 2024 14:11:58 +0200 Subject: [PATCH 049/127] WIP: pass cycles but this still crashes :-( --- src/codegen/compile.ml | 7 ++++++- src/ir_def/arrange_ir.ml | 2 +- src/prelude/internals.mo | 13 ++++++++++++- 3 files changed, 19 insertions(+), 3 deletions(-) diff --git a/src/codegen/compile.ml b/src/codegen/compile.ml index 78bbb93e7aa..e43b28ab585 100644 --- a/src/codegen/compile.ml +++ b/src/codegen/compile.ml @@ -9111,6 +9111,7 @@ module Internals = struct 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 env ae "@pass_cycles" end (* This comes late because it also deals with messages *) @@ -12062,7 +12063,11 @@ and compile_exp_with_hint (env : E.t) ae sr_hint exp = 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}])))) -> + compile_exp_vanilla env ae cyc ^^ Internals.pass_cycles env ae + | _ -> Opt.null_lit env ^^ Internals.pass_cycles env ae in FuncDec.async_body env ae ts captured mk_body exp.at ^^ Tagged.load_forwarding_pointer env ^^ set_future ^^ diff --git a/src/ir_def/arrange_ir.ml b/src/ir_def/arrange_ir.ml index 7a545072887..a63dcb86cff 100644 --- a/src/ir_def/arrange_ir.ml +++ b/src/ir_def/arrange_ir.ml @@ -29,7 +29,7 @@ let rec exp e = match e.it with | 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 (_FIXME, 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" $$ [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 diff --git a/src/prelude/internals.mo b/src/prelude/internals.mo index 17fbe99cf3d..76b58c81b34 100644 --- a/src/prelude/internals.mo +++ b/src/prelude/internals.mo @@ -9,6 +9,16 @@ code, and cannot be shadowed. type @Iter = {next : () -> ?T_}; +// Function called by backend to add funds to call. +// DO NOT RENAME without modifying compilation. +func @pass_cycles(par : ?{ cycles : Nat }) { + @reset_cycles(); + let ?{ cycles } = par else return; + if (cycles != 0) { + (prim "cyclesAdd" : Nat -> ()) cycles; + } +}; + var @cycles : Nat = 0; // Function called by backend to add funds to call. @@ -17,10 +27,11 @@ func @add_cycles() { let cycles = @cycles; @reset_cycles(); if (cycles != 0) { - (prim "cyclesAdd" : Nat -> ()) (cycles); + (prim "cyclesAdd" : Nat -> ()) cycles; } }; + // Function called by backend to zero cycles on context switch. // DO NOT RENAME without modifying compilation. func @reset_cycles() { From 8628695c6a79dba0a6221f1b2c1439c14a66b4d9 Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Tue, 6 Aug 2024 14:31:25 +0200 Subject: [PATCH 050/127] WIP: crash is fixed --- src/codegen/compile.ml | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/src/codegen/compile.ml b/src/codegen/compile.ml index e43b28ab585..fba01b7492d 100644 --- a/src/codegen/compile.ml +++ b/src/codegen/compile.ml @@ -9101,17 +9101,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 env ae "@pass_cycles" + let pass_cycles env ae = call_prelude_function_with_args env ae "@pass_cycles" end (* This comes late because it also deals with messages *) @@ -12066,8 +12070,8 @@ and compile_exp_with_hint (env : E.t) ae sr_hint exp = 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}])))) -> - compile_exp_vanilla env ae cyc ^^ Internals.pass_cycles env ae - | _ -> Opt.null_lit env ^^ Internals.pass_cycles env ae in + 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 ^^ From 016ac58b352ada790fab28e04dbb4c1698445dc5 Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Tue, 6 Aug 2024 14:43:55 +0200 Subject: [PATCH 051/127] fix up `ICCyclesPrim`'s type --- src/ir_def/construct.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/ir_def/construct.ml b/src/ir_def/construct.ml index 95ba94537ed..0ae5d6d0517 100644 --- a/src/ir_def/construct.ml +++ b/src/ir_def/construct.ml @@ -111,7 +111,7 @@ let primE prim es = | SystemCyclesAcceptPrim -> T.nat | DeserializePrim ts -> T.seq ts | DeserializeOptPrim ts -> T.Opt (T.seq ts) - | ICCyclesPrim -> T.(Opt (Obj (Object, [(* FIXME *)]))) + | ICCyclesPrim -> T.(Opt (Obj (Object, [{ lab = "cycles"; typ = nat; src = empty_src}]))) | OtherPrim "trap" -> T.Non | OtherPrim "call_perform_status" -> T.(Prim Nat32) | OtherPrim "call_perform_message" -> T.text From 9c611a91ea760f796492c601da4958f37b92346e Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Tue, 6 Aug 2024 16:38:20 +0200 Subject: [PATCH 052/127] remove legacy `Cycles.add` --- test/run-drun/clone.mo | 2 -- 1 file changed, 2 deletions(-) diff --git a/test/run-drun/clone.mo b/test/run-drun/clone.mo index 49bd06be244..a4871d65e53 100644 --- a/test/run-drun/clone.mo +++ b/test/run-drun/clone.mo @@ -1,4 +1,3 @@ -//MOC-FLAG -dl import Prim "mo:⛔"; import Cycles "cycles/cycles"; import Lib "clone/cloneable"; @@ -10,7 +9,6 @@ actor Cloner { public shared func makeCloneable(init : Nat): async Lib.Cloneable { let accepted = Cycles.accept(Cycles.available()); Prim.debugPrint(debug_show {accepted}); - Cycles.add(accepted); // FIXME: remove await (with cycles = accepted) Lib.Cloneable(makeCloneable, init); }; From ee4e2c91e06fe371c20583a2c29e8f32db9487d1 Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Wed, 7 Aug 2024 13:29:36 +0200 Subject: [PATCH 053/127] WIP: allow decorations on `AsyncE` --- src/lowering/desugar.ml | 2 +- src/mo_def/arrange.ml | 4 ++-- src/mo_def/compUnit.ml | 4 ++-- src/mo_def/syntax.ml | 8 ++++---- src/mo_frontend/definedness.ml | 2 +- src/mo_frontend/effect.ml | 4 ++-- src/mo_frontend/parser.mly | 11 ++++++----- src/mo_frontend/traversals.ml | 2 +- src/mo_frontend/typing.ml | 16 ++++++++-------- src/mo_interpreter/interpret.ml | 4 ++-- src/viper/trans.ml | 4 ++-- src/viper/traversals.ml | 2 +- 12 files changed, 32 insertions(+), 31 deletions(-) diff --git a/src/lowering/desugar.ml b/src/lowering/desugar.ml index 648003f60df..0bbfc974b47 100644 --- a/src/lowering/desugar.ml +++ b/src/lowering/desugar.ml @@ -236,7 +236,7 @@ and exp' at note = function | S.BreakE (l, e) -> (breakE l.it (exp e)).it | S.RetE e -> (retE (exp e)).it | S.ThrowE e -> I.PrimE (I.ThrowPrim, [exp e]) - | S.AsyncE (s, tb, e) -> + | S.AsyncE (_FIXME, s, tb, e) -> I.AsyncE (s, typ_bind tb, exp e, match note.Note.typ with | T.Async (_, t, _) -> t diff --git a/src/mo_def/arrange.ml b/src/mo_def/arrange.ml index bbcafb172ad..8de34b00732 100644 --- a/src/mo_def/arrange.ml +++ b/src/mo_def/arrange.ml @@ -104,8 +104,8 @@ module Make (Cfg : Config) = struct | DebugE e -> "DebugE" $$ [exp e] | BreakE (i, e) -> "BreakE" $$ [id i; exp e] | RetE e -> "RetE" $$ [exp e] - | AsyncE (Type.Fut, tb, e) -> "AsyncE" $$ [typ_bind tb; exp e] - | AsyncE (Type.Cmp, tb, e) -> "AsyncE*" $$ [typ_bind tb; exp e] + | AsyncE (_FIXME, Type.Fut, tb, e) -> "AsyncE" $$ [typ_bind tb; exp e] + | AsyncE (None, Type.Cmp, tb, e) -> "AsyncE*" $$ [typ_bind tb; exp e] | AwaitE (Type.Fut, e) -> "AwaitE" $$ [exp e] | AwaitE (Type.Cmp, e) -> "AwaitE*" $$ [exp e] | AssertE (Runtime, e) -> "AssertE" $$ [exp e] diff --git a/src/mo_def/compUnit.ml b/src/mo_def/compUnit.ml index 9496976edb9..7e68f0cfd39 100644 --- a/src/mo_def/compUnit.ml +++ b/src/mo_def/compUnit.ml @@ -8,13 +8,13 @@ open Syntax let is_actor_def e = let open Source in match e.it with - | AwaitE (Type.Fut, { it = AsyncE (Type.Fut, _, {it = ObjBlockE ({ it = Type.Actor; _}, _t, _fields); _ }) ; _ }) -> true + | AwaitE (Type.Fut, { it = AsyncE (_, Type.Fut, _, {it = ObjBlockE ({ it = Type.Actor; _}, _t, _fields); _ }) ; _ }) -> true | _ -> false let as_actor_def e = let open Source in match e.it with - | AwaitE (Type.Fut, { it = AsyncE (Type.Fut, _, {it = ObjBlockE ({ it = Type.Actor; _}, _t, fields); note; at }) ; _ }) -> + | AwaitE (Type.Fut, { it = AsyncE (_, Type.Fut, _, {it = ObjBlockE ({ it = Type.Actor; _}, _t, fields); note; at }) ; _ }) -> fields, note, at | _ -> assert false diff --git a/src/mo_def/syntax.ml b/src/mo_def/syntax.ml index 135b7fe9674..9ba360de7f3 100644 --- a/src/mo_def/syntax.ml +++ b/src/mo_def/syntax.ml @@ -187,7 +187,7 @@ and exp' = | BreakE of id * exp (* break *) | RetE of exp (* return *) | DebugE of exp (* debugging *) - | AsyncE of async_sort * typ_bind * exp (* future / computation *) + | AsyncE of exp option * async_sort * typ_bind * exp (* future / computation *) | AwaitE of async_sort * exp (* await *) | AssertE of assert_kind * exp (* assertion *) | AnnotE of exp * typ (* type annotation *) @@ -318,11 +318,11 @@ let scopeT at = (* Expressions *) let asyncE sort tbs e = - AsyncE (sort, tbs, e) @? e.at + AsyncE (None, sort, tbs, e) @? e.at let ignore_asyncE tbs e = IgnoreE ( - AnnotE (AsyncE (Type.Fut, tbs, e) @? e.at, + AnnotE (AsyncE (None, Type.Fut, tbs, e) @? e.at, AsyncT (Type.Fut, scopeT e.at, TupT [] @! e.at) @! e.at) @? e.at ) @? e.at let is_asyncE e = @@ -333,7 +333,7 @@ let is_asyncE e = let is_ignore_asyncE e = match e.it with | IgnoreE - {it = AnnotE ({it = AsyncE (Type.Fut, _, _); _}, + {it = AnnotE ({it = AsyncE (None, Type.Fut, _, _); _}, {it = AsyncT (Type.Fut, _, {it = TupT []; _}); _}); _} -> true | _ -> false diff --git a/src/mo_frontend/definedness.ml b/src/mo_frontend/definedness.ml index b5443908b65..3cd5dfe4960 100644 --- a/src/mo_frontend/definedness.ml +++ b/src/mo_frontend/definedness.ml @@ -125,7 +125,7 @@ let rec exp msgs e : f = match e.it with | ForE (p, e1, e2) -> exp msgs e1 ++ (exp msgs e2 /// pat msgs p) | LabelE (i, t, e) -> exp msgs e | DebugE e -> exp msgs e - | AsyncE (_, _, e) -> exp msgs e + | AsyncE (_FIXME, _, _, e) -> exp msgs e | AwaitE (_, e) -> exp msgs e | AssertE (_, e) -> exp msgs e | AnnotE (e, t) -> exp msgs e diff --git a/src/mo_frontend/effect.ml b/src/mo_frontend/effect.ml index 50d93296d18..064ef93044a 100644 --- a/src/mo_frontend/effect.ml +++ b/src/mo_frontend/effect.ml @@ -111,9 +111,9 @@ let rec infer_effect_exp (exp:Syntax.exp) : T.eff = let e1 = effect_exp exp1 in let e2 = effect_cases cases in max_eff e1 e2 - | AsyncE (T.Fut, _, _) -> + | AsyncE (_, T.Fut, _, _) -> T.Await - | AsyncE (T.Cmp, _, _) -> + | AsyncE (_, T.Cmp, _, _) -> T.Triv | ThrowE _ | TryE _ diff --git a/src/mo_frontend/parser.mly b/src/mo_frontend/parser.mly index bfabdc603a5..3855f9dc7f6 100644 --- a/src/mo_frontend/parser.mly +++ b/src/mo_frontend/parser.mly @@ -675,9 +675,9 @@ exp_un(B) : | RETURN e=exp(ob) { RetE(e) @? at $sloc } | ASYNC e=exp_nest - { AsyncE(Type.Fut, scope_bind (anon_id "async" (at $sloc)) (at $sloc), e) @? at $sloc } + { AsyncE(None, Type.Fut, scope_bind (anon_id "async" (at $sloc)) (at $sloc), e) @? at $sloc } | ASYNCSTAR e=exp_nest - { AsyncE(Type.Cmp, scope_bind (anon_id "async*" (at $sloc)) (at $sloc), e) @? at $sloc } + { AsyncE(None, Type.Cmp, scope_bind (anon_id "async*" (at $sloc)) (at $sloc), e) @? at $sloc } | AWAIT e=exp_nest { AwaitE(Type.Fut, e) @? at $sloc } | AWAITSTAR e=exp_nest @@ -707,8 +707,9 @@ exp_un(B) : { match e.it with | CallE (None, f, is, args) -> { e with it = CallE (Some (ObjE(Option.to_list base, fs) @? e.at), f, is, args) } - | AsyncE (Type.Fut, _, _) -> e - | _ -> { e with it = ObjE(Option.to_list base, fs) } + | AsyncE (None, Type.Fut, binds, exp) -> + { e with it = AsyncE (Some (ObjE(Option.to_list base, fs) @? e.at), Type.Fut, binds, exp) } + | _ -> { e with it = ObjE(Option.to_list base, fs) } (* FIXME: meh *) } | IF b=exp_nullary(ob) e1=exp_nest %prec IF_NO_ELSE { IfE(b, e1, TupE([]) @? at $sloc) @? at $sloc } @@ -881,7 +882,7 @@ dec_nonvar : if s.it = Type.Actor then AwaitE (Type.Fut, - AsyncE(Type.Fut, scope_bind (anon_id "async" (at $sloc)) (at $sloc), + AsyncE(None, Type.Fut, scope_bind (anon_id "async" (at $sloc)) (at $sloc), objblock s t (List.map share_dec_field efs) @? at $sloc) @? at $sloc) @? at $sloc else objblock s t efs @? at $sloc diff --git a/src/mo_frontend/traversals.ml b/src/mo_frontend/traversals.ml index 5415e017c58..d00db167f77 100644 --- a/src/mo_frontend/traversals.ml +++ b/src/mo_frontend/traversals.ml @@ -20,7 +20,7 @@ let rec over_exp (f : exp -> exp) (exp : exp) : exp = match exp.it with | BreakE (x, exp1) -> f { exp with it = BreakE (x, over_exp f exp1) } | RetE exp1 -> f { exp with it = RetE (over_exp f exp1) } | AnnotE (exp1, x) -> f { exp with it = AnnotE (over_exp f exp1, x) } - | AsyncE (s, tb, exp1) -> f { exp with it = AsyncE (s, tb, over_exp f exp1) } + | AsyncE (par, s, tb, exp1) -> f { exp with it = AsyncE (Option.map (over_exp f) par, s, tb, over_exp f exp1) } | AwaitE (s, exp1) -> f { exp with it = AwaitE (s, over_exp f exp1) } | ThrowE exp1 -> f { exp with it = ThrowE (over_exp f exp1) } | BinE (x, exp1, y, exp2) -> diff --git a/src/mo_frontend/typing.ml b/src/mo_frontend/typing.ml index bed3ae21b7b..26c61a999f9 100644 --- a/src/mo_frontend/typing.ml +++ b/src/mo_frontend/typing.ml @@ -950,7 +950,7 @@ let rec is_explicit_exp e = | LitE l -> is_explicit_lit !l | UnE (_, _, e1) | OptE e1 | DoOptE e1 | ProjE (e1, _) | DotE (e1, _) | BangE e1 | IdxE (e1, _) | CallE (_(*FIXME: correct?*), e1, _, _) - | LabelE (_, _, e1) | AsyncE (_, _, e1) | AwaitE (_, e1) -> + | LabelE (_, _, e1) | AsyncE (_, _, _, e1) | AwaitE (_, e1) -> is_explicit_exp e1 | BinE (_, e1, _, e2) | IfE (_, e1, e2) -> is_explicit_exp e1 || is_explicit_exp e2 @@ -1616,8 +1616,8 @@ and infer_exp'' env exp : T.typ = check_exp_strong env T.throw exp1 end; T.Non - | AsyncE (s, typ_bind, exp1) -> - error_in [Flags.WASIMode; Flags.WasmMode] env exp1.at "M0086" + | AsyncE (_, s, typ_bind, exp1) -> + error_in Flags.[WASIMode; WasmMode] env exp1.at "M0086" "async expressions are not supported"; let t1, next_cap = check_AsyncCap env "async expression" exp.at in let c, tb, ce, cs = check_typ_bind env typ_bind in @@ -1792,8 +1792,8 @@ and check_exp' env0 t exp : T.typ = display_typ_expand (T.Array t'); List.iter (check_exp env (T.as_immut t')) exps; t - | AsyncE (s1, tb, exp1), T.Async (s2, t1', t') -> - error_in [Flags.WASIMode; Flags.WasmMode] env exp1.at "M0086" + | AsyncE (_FIXME, s1, tb, exp1), T.Async (s2, t1', t') -> + error_in Flags.[WASIMode; WasmMode] env exp1.at "M0086" "async expressions are not supported"; let t1, next_cap = check_AsyncCap env "async expression" exp.at in if s1 <> s2 then begin @@ -2714,7 +2714,7 @@ and gather_dec env scope dec : Scope.t = | LetD ( {it = VarP id; _}, ( {it = ObjBlockE (obj_sort, _, dec_fields); at; _} - | {it = AwaitE (_,{ it = AsyncE (_, _, {it = ObjBlockE ({ it = Type.Actor; _} as obj_sort, _, dec_fields); at; _}) ; _ }); _ }), + | {it = AwaitE (_,{ it = AsyncE (_, _, _, {it = ObjBlockE ({ it = Type.Actor; _} as obj_sort, _, dec_fields); at; _}) ; _ }); _ }), _ ) -> let decs = List.map (fun df -> df.it.dec) dec_fields in @@ -2802,7 +2802,7 @@ and infer_dec_typdecs env dec : Scope.t = | LetD ( {it = VarP id; _}, ( {it = ObjBlockE (obj_sort, _t, dec_fields); at; _} - | {it = AwaitE (_, { it = AsyncE (_, _, {it = ObjBlockE ({ it = Type.Actor; _} as obj_sort, _t, dec_fields); at; _}) ; _ }); _ }), + | {it = AwaitE (_, { it = AsyncE (_, _, _, {it = ObjBlockE ({ it = Type.Actor; _} as obj_sort, _t, dec_fields); at; _}) ; _ }); _ }), _ ) -> let decs = List.map (fun {it = {vis; dec; _}; _} -> dec) dec_fields in @@ -2888,7 +2888,7 @@ and infer_dec_valdecs env dec : Scope.t = | LetD ( {it = VarP id; _} as pat, ( {it = ObjBlockE (obj_sort, _t, dec_fields); at; _} - | {it = AwaitE (_, { it = AsyncE (_, _, {it = ObjBlockE ({ it = Type.Actor; _} as obj_sort, _t, dec_fields); at; _}) ; _ }); _ }), + | {it = AwaitE (_, { it = AsyncE (_, _, _, {it = ObjBlockE ({ it = Type.Actor; _} as obj_sort, _t, dec_fields); at; _}) ; _ }); _ }), _ ) -> let decs = List.map (fun df -> df.it.dec) dec_fields in diff --git a/src/mo_interpreter/interpret.ml b/src/mo_interpreter/interpret.ml index 8e9820e6437..74c7b158cc7 100644 --- a/src/mo_interpreter/interpret.ml +++ b/src/mo_interpreter/interpret.ml @@ -681,14 +681,14 @@ and interpret_exp_mut env exp (k : V.value V.cont) = interpret_exp env exp1 (Option.get env.rets) | ThrowE exp1 -> interpret_exp env exp1 (Option.get env.throws) - | AsyncE (T.Fut, _, exp1) -> + | AsyncE (_FIXME, T.Fut, _, exp1) -> async env exp.at (fun k' r -> let env' = {env with labs = V.Env.empty; rets = Some k'; throws = Some r} in interpret_exp env' exp1 k') k - | AsyncE (T.Cmp, _, exp1) -> + | AsyncE (_FIXME, T.Cmp, _, exp1) -> k (V.Comp (fun k' r -> let env' = {env with labs = V.Env.empty; rets = Some k'; throws = Some r} in interpret_exp env' exp1 k')) diff --git a/src/viper/trans.ml b/src/viper/trans.ml index 02725a17a9f..b726aa27605 100644 --- a/src/viper/trans.ml +++ b/src/viper/trans.ml @@ -392,7 +392,7 @@ and dec_field' ctxt d = (* async functions *) | M.(LetD ({it=VarP f;note;_}, {it=FuncE(x, sp, tp, p, t_opt, sugar, - {it = AsyncE (T.Fut, _, e); _} );_}, None)) -> (* ignore async *) + {it = AsyncE (_, T.Fut, _, e); _} );_}, None)) -> (* ignore async *) { ctxt with ids = Env.add f.it (Method, note) ctxt.ids }, None, (* no perm *) None, (* no init *) @@ -577,7 +577,7 @@ and stmt ctxt (s : M.exp) : seqn = | M.IfE(e, s1, s2) -> !!([], [ !!(IfS(exp ctxt e, stmt ctxt s1, stmt ctxt s2))]) - | M.(AwaitE(T.Fut, { it = AsyncE (T.Fut, _, e); at; _ })) -> (* gross hack *) + | M.(AwaitE(T.Fut, { it = AsyncE (_, T.Fut, _, e); at; _ })) -> (* gross hack *) let id = fresh_id "$message_async" in let (!!) p = !!! (s.at) p in let (!@) p = !!! at p in diff --git a/src/viper/traversals.ml b/src/viper/traversals.ml index 11328457690..9aa7036a72f 100644 --- a/src/viper/traversals.ml +++ b/src/viper/traversals.ml @@ -29,7 +29,7 @@ let rec over_exp (v : visitor) (exp : exp) : exp = | BreakE (x, exp1) -> { exp with it = BreakE (x, over_exp v exp1) } | RetE exp1 -> { exp with it = RetE (over_exp v exp1) } | AnnotE (exp1, t) -> { exp with it = AnnotE (over_exp v exp1, over_typ v t) } - | AsyncE (s, tb, exp1) -> { exp with it = AsyncE (s, tb, over_exp v exp1) } + | AsyncE (par, s, tb, exp1) -> { exp with it = AsyncE (Option.map (over_exp v) par, s, tb, over_exp v exp1) } | AwaitE (s, exp1) -> { exp with it = AwaitE (s, over_exp v exp1) } | ThrowE exp1 -> { exp with it = ThrowE (over_exp v exp1) } | BinE (x, exp1, y, exp2) -> { exp with it = BinE (x, over_exp v exp1, y, over_exp v exp2) } From 4279b9621de0aed7b20f3518714f79c1f137796b Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Wed, 7 Aug 2024 13:37:15 +0200 Subject: [PATCH 054/127] arrange parenthetical --- src/mo_def/arrange.ml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/mo_def/arrange.ml b/src/mo_def/arrange.ml index 8de34b00732..7dc899d9c79 100644 --- a/src/mo_def/arrange.ml +++ b/src/mo_def/arrange.ml @@ -104,7 +104,8 @@ module Make (Cfg : Config) = struct | DebugE e -> "DebugE" $$ [exp e] | BreakE (i, e) -> "BreakE" $$ [id i; exp e] | RetE e -> "RetE" $$ [exp e] - | AsyncE (_FIXME, Type.Fut, tb, e) -> "AsyncE" $$ [typ_bind tb; exp e] + | AsyncE (None, Type.Fut, tb, e) -> "AsyncE" $$ [typ_bind tb; exp e] + | AsyncE (Some par, Type.Fut, tb, e) -> "AsyncE()" $$ [exp par; typ_bind tb; exp e] | AsyncE (None, Type.Cmp, tb, e) -> "AsyncE*" $$ [typ_bind tb; exp e] | AwaitE (Type.Fut, e) -> "AwaitE" $$ [exp e] | AwaitE (Type.Cmp, e) -> "AwaitE*" $$ [exp e] From 0f35682286c524652abbdb588ece0f122f082f7d Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Wed, 7 Aug 2024 18:13:32 +0200 Subject: [PATCH 055/127] WIP: compiles --- src/ir_def/arrange_ir.ml | 4 ++-- src/ir_def/check_ir.ml | 2 +- src/ir_def/construct.ml | 16 ++++++++-------- src/ir_def/freevars.ml | 2 +- src/ir_def/ir.ml | 2 +- src/ir_def/ir_effect.ml | 4 ++-- src/ir_def/rename.ml | 2 +- src/ir_interpreter/interpret_ir.ml | 4 ++-- src/ir_passes/await.ml | 10 +++++----- src/ir_passes/const.ml | 2 +- src/ir_passes/eq.ml | 2 +- src/ir_passes/erase_typ_field.ml | 4 ++-- src/ir_passes/show.ml | 2 +- src/ir_passes/tailcall.ml | 2 +- src/lowering/desugar.ml | 10 +++++----- 15 files changed, 34 insertions(+), 34 deletions(-) diff --git a/src/ir_def/arrange_ir.ml b/src/ir_def/arrange_ir.ml index a63dcb86cff..f693886dc1a 100644 --- a/src/ir_def/arrange_ir.ml +++ b/src/ir_def/arrange_ir.ml @@ -22,8 +22,8 @@ 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" $$ [exp par; 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) -> diff --git a/src/ir_def/check_ir.ml b/src/ir_def/check_ir.ml index 1012f2e6ae1..4cae2ecbddb 100644 --- a/src/ir_def/check_ir.ml +++ b/src/ir_def/check_ir.ml @@ -744,7 +744,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 diff --git a/src/ir_def/construct.ml b/src/ir_def/construct.ml index 0ae5d6d0517..680f581638c 100644 --- a/src/ir_def/construct.ml +++ b/src/ir_def/construct.ml @@ -141,14 +141,6 @@ let assertE e = } -let asyncE s typ_bind e typ1 = - { it = AsyncE (s, typ_bind, e, typ1); - at = no_region; - note = - Note.{ def with typ = T.Async (s, typ1, typ e); - eff = T.(if s = Fut then Await else Triv) } - } - let awaitE s e = let (s, _ , typ) = T.as_async (T.normalize (typ e)) in { it = PrimE (AwaitPrim s, [e]); @@ -314,6 +306,14 @@ let funcE name sort ctrl typ_binds args typs exp = let recordE' = ref (fun _ -> nullE ()) (* gets correctly filled below *) +let asyncE s typ_bind e typ1 = + { it = AsyncE (!recordE' [], s, typ_bind, e, typ1); + at = no_region; + note = + Note.{ def with typ = T.Async (s, typ1, typ e); + eff = T.(if s = Fut then Await else Triv) } + } + let callE exp1 typs exp2 = let typ = match T.promote (typ exp1) with | T.Func (_sort, control, _, _, ret_tys) -> diff --git a/src/ir_def/freevars.ml b/src/ir_def/freevars.ml index 7c04f5917ac..67e2e3da4a7 100644 --- a/src/ir_def/freevars.ml +++ b/src/ir_def/freevars.ml @@ -112,7 +112,7 @@ let rec exp e : f = match e.it with | SwitchE (e, cs) -> exp e ++ cases cs | LoopE e1 -> exp e1 | LabelE (i, t, e) -> exp e - | AsyncE (_, _, e, _) -> exp e + | AsyncE (par, _, _, e, _) -> exp par ++ exp e | DeclareE (i, t, e) -> exp e // i | DefineE (i, m, e) -> id i ++ exp e | FuncE (x, s, c, tp, as_, t, e) -> under_lambda (exp e /// args as_) diff --git a/src/ir_def/ir.ml b/src/ir_def/ir.ml index 9bdfd4ebcb5..9b703354876 100644 --- a/src/ir_def/ir.ml +++ b/src/ir_def/ir.ml @@ -66,7 +66,7 @@ and exp' = | SwitchE of exp * case list (* switch *) | LoopE of exp (* do-while loop *) | LabelE of id * Type.typ * exp (* label *) - | AsyncE of Type.async_sort * typ_bind * exp * Type.typ (* async/async* *) + | AsyncE of exp * Type.async_sort * typ_bind * exp * Type.typ (* async/async* *) | DeclareE of id * Type.typ * exp (* local promise *) | DefineE of id * mut * exp (* promise fulfillment *) | FuncE of (* function *) diff --git a/src/ir_def/ir_effect.ml b/src/ir_def/ir_effect.ml index 435e77257ed..46d412d67f7 100644 --- a/src/ir_def/ir_effect.ml +++ b/src/ir_def/ir_effect.ml @@ -69,9 +69,9 @@ and infer_effect_exp (exp: exp) : T.eff = let e1 = effect_exp exp1 in let e2 = effect_cases cases in max_eff e1 e2 - | AsyncE (T.Fut, _, _, _) -> + | AsyncE (_, T.Fut, _, _, _) -> T.Await - | AsyncE (T.Cmp, _, _, _) -> + | AsyncE (_, T.Cmp, _, _, _) -> T.Triv | TryE _ -> T.Await diff --git a/src/ir_def/rename.ml b/src/ir_def/rename.ml index d3b7d32c30b..8c811adbef3 100644 --- a/src/ir_def/rename.ml +++ b/src/ir_def/rename.ml @@ -54,7 +54,7 @@ and exp' rho = function | LoopE e1 -> LoopE (exp rho e1) | LabelE (i, t, e) -> let i',rho' = id_bind rho i in LabelE(i', t, exp rho' e) - | AsyncE (s, tb, e, t) -> AsyncE (s, tb, exp rho e, t) + | AsyncE (par, s, tb, e, t) -> AsyncE (exp rho par, s, tb, exp rho e, t) | DeclareE (i, t, e) -> let i',rho' = id_bind rho i in DeclareE (i', t, exp rho' e) | DefineE (i, m, e) -> DefineE (id rho i, m, exp rho e) diff --git a/src/ir_interpreter/interpret_ir.ml b/src/ir_interpreter/interpret_ir.ml index c3effe26d4d..4ba333a3c64 100644 --- a/src/ir_interpreter/interpret_ir.ml +++ b/src/ir_interpreter/interpret_ir.ml @@ -512,7 +512,7 @@ and interpret_exp_mut env exp (k : V.value V.cont) = | LabelE (id, _typ, exp1) -> let env' = {env with labs = V.Env.add id k env.labs} in interpret_exp env' exp1 k - | AsyncE (Type.Fut, _, exp1, _) -> + | AsyncE (_FIXME, Type.Fut, _, exp1, _) -> assert env.flavor.has_await; async env exp.at @@ -520,7 +520,7 @@ and interpret_exp_mut env exp (k : V.value V.cont) = let env' = { env with labs = V.Env.empty; rets = Some k'; throws = Some r } in interpret_exp env' exp1 k') k - | AsyncE (Type.Cmp, _, exp1, _) -> + | AsyncE (_, Type.Cmp, _, exp1, _) -> assert env.flavor.has_await; k (V.Comp (fun k' r -> let env' = { env with labs = V.Env.empty; rets = Some k'; throws = Some r } diff --git a/src/ir_passes/await.ml b/src/ir_passes/await.ml index 9736cc31442..8dbb1e84513 100644 --- a/src/ir_passes/await.ml +++ b/src/ir_passes/await.ml @@ -77,7 +77,7 @@ let typ_cases cases = List.fold_left (fun t case -> T.lub t (typ case.it.exp)) T let rec t_async context exp = match exp.it with - | AsyncE (s, tb, exp1, typ1) -> + | AsyncE (_FIXME, s, tb, exp1, typ1) -> let exp1 = R.exp R.Renaming.empty exp1 in (* rename all bound vars apart *) (*Why?*) (* add the implicit return label *) let k_ret = fresh_cont (typ exp1) T.unit in @@ -133,9 +133,9 @@ and t_exp' context exp = | Some Label -> (retE (t_exp context exp1)).it | None -> assert false end - | AsyncE (T.Cmp, _, _, _) -> + | AsyncE (_, T.Cmp, _, _, _) -> (t_async context exp).it - | AsyncE (T.Fut, _, _, _) -> + | AsyncE (_, T.Fut, _, _, _) -> assert false (* must have effect T.Await *) | TryE _ -> assert false (* these never have effect T.Triv *) | DeclareE (id, typ, exp1) -> @@ -415,9 +415,9 @@ and c_exp' context exp k = | Some (Cont k') -> c_exp context exp1 k' | _ -> assert false end - | AsyncE (T.Cmp, tb, exp1, typ1) -> + | AsyncE (_, T.Cmp, tb, exp1, typ1) -> assert false (* must have effect T.Triv, handled by first case *) - | AsyncE (T.Fut, tb, exp1, typ1) -> + | AsyncE (_FIXME, T.Fut, tb, exp1, typ1) -> (* add the implicit return label *) let k_ret = fresh_cont (typ exp1) T.unit in let k_fail = fresh_err_cont T.unit in diff --git a/src/ir_passes/const.ml b/src/ir_passes/const.ml index cb56fcacbf9..65929bdd792 100644 --- a/src/ir_passes/const.ml +++ b/src/ir_passes/const.ml @@ -136,7 +136,7 @@ let rec exp lvl (env : env) e : Lbool.t = | DeclareE (id, _, e1) -> exp_ lvl (M.add id no_info env) e1; surely_false - | LoopE e1 | AsyncE (_, _, e1, _) -> + | LoopE e1 | AsyncE (_(*FIXME*), _, _, e1, _) -> exp_ NotTopLvl env e1; surely_false | AssignE (_, e1) | LabelE (_, _, e1) | DefineE (_, _, e1) -> diff --git a/src/ir_passes/eq.ml b/src/ir_passes/eq.ml index 6e1bff11e5d..f8671d1bc4e 100644 --- a/src/ir_passes/eq.ml +++ b/src/ir_passes/eq.ml @@ -241,7 +241,7 @@ and t_exp' env = function LoopE (t_exp env exp1) | LabelE (id, typ, exp1) -> LabelE (id, typ, t_exp env exp1) - | AsyncE (s, tb, e, typ) -> AsyncE (s, tb, t_exp env e, typ) + | AsyncE (par, s, tb, e, typ) -> AsyncE (t_exp env par, s, tb, t_exp env e, typ) | DeclareE (id, typ, exp1) -> DeclareE (id, typ, t_exp env exp1) | DefineE (id, mut ,exp1) -> diff --git a/src/ir_passes/erase_typ_field.ml b/src/ir_passes/erase_typ_field.ml index 3a4ecaea0c8..3775ae21b2d 100644 --- a/src/ir_passes/erase_typ_field.ml +++ b/src/ir_passes/erase_typ_field.ml @@ -117,8 +117,8 @@ let transform prog = LoopE (t_exp exp1) | LabelE (id, typ, exp1) -> LabelE (id, t_typ typ, t_exp exp1) - | AsyncE (s, tb, exp1, typ) -> - AsyncE (s, t_typ_bind tb, t_exp exp1, t_typ typ) + | AsyncE (par, s, tb, exp1, typ) -> + AsyncE (t_exp par, s, t_typ_bind tb, t_exp exp1, t_typ typ) | TryE (exp1, cases, vt) -> TryE (t_exp exp1, List.map t_case cases, vt) | DeclareE (id, typ, exp1) -> diff --git a/src/ir_passes/show.ml b/src/ir_passes/show.ml index 38cb8583e61..4ff6e070d42 100644 --- a/src/ir_passes/show.ml +++ b/src/ir_passes/show.ml @@ -283,7 +283,7 @@ and t_exp' env = function LoopE (t_exp env exp1) | LabelE (id, typ, exp1) -> LabelE (id, typ, t_exp env exp1) - | AsyncE (s, tb, e, typ) -> AsyncE (s, tb, t_exp env e, typ) + | AsyncE (par, s, tb, e, typ) -> AsyncE (t_exp env par, s, tb, t_exp env e, typ) | DeclareE (id, typ, exp1) -> DeclareE (id, typ, t_exp env exp1) | DefineE (id, mut ,exp1) -> diff --git a/src/ir_passes/tailcall.ml b/src/ir_passes/tailcall.ml index 029c16ae2b9..6ddab516efb 100644 --- a/src/ir_passes/tailcall.ml +++ b/src/ir_passes/tailcall.ml @@ -111,7 +111,7 @@ and exp' env e : exp' = match e.it with | LabelE (i, t, e) -> let env1 = bind env i None in LabelE(i, t, exp env1 e) | PrimE (RetPrim, [e])-> PrimE (RetPrim, [tailexp { env with tail_pos = true } e]) - | AsyncE (s, tb, e, typ) -> AsyncE (s, tb, exp { tail_pos = true; info = None } e, typ) + | AsyncE (par, s, tb, e, typ) -> AsyncE (exp env par, s, tb, exp { tail_pos = true; info = None } e, typ) | DeclareE (i, t, e) -> let env1 = bind env i None in DeclareE (i, t, tailexp env1 e) | DefineE (i, m, e) -> DefineE (i, m, exp env e) diff --git a/src/lowering/desugar.ml b/src/lowering/desugar.ml index 0bbfc974b47..cd59f2582a4 100644 --- a/src/lowering/desugar.ml +++ b/src/lowering/desugar.ml @@ -237,7 +237,7 @@ and exp' at note = function | S.RetE e -> (retE (exp e)).it | S.ThrowE e -> I.PrimE (I.ThrowPrim, [exp e]) | S.AsyncE (_FIXME, s, tb, e) -> - I.AsyncE (s, typ_bind tb, exp e, + I.AsyncE (recordE [], s, typ_bind tb, exp e, match note.Note.typ with | T.Async (_, t, _) -> t | _ -> assert false) @@ -924,12 +924,12 @@ and to_args typ po p : Ir.arg list * (Ir.exp -> Ir.exp) * T.control * T.typ list let wrap_under_async e = if T.is_shared_sort sort then match control, e.it with - | (T.Promises, Ir.AsyncE (s, tb, e', t)) -> - { e with it = Ir.AsyncE (s, tb, wrap_po e', t) } + | (T.Promises, Ir.AsyncE (par, s, tb, e', t)) -> + { e with it = Ir.AsyncE (par, s, tb, wrap_po e', t) } | T.Returns, Ir.BlockE ( - [{ it = Ir.LetD ({ it = Ir.WildP; _} as pat, ({ it = Ir.AsyncE (T.Fut, tb,e',t); _} as exp)); _ }], + [{ it = Ir.LetD ({ it = Ir.WildP; _} as pat, ({ it = Ir.AsyncE (par, T.Fut, tb,e',t); _} as exp)); _ }], ({ it = Ir.PrimE (Ir.TupPrim, []); _} as unit)) -> - blockE [letP pat {exp with it = Ir.AsyncE (T.Fut, tb,wrap_po e',t)} ] unit + blockE [letP pat {exp with it = Ir.AsyncE (par, T.Fut, tb, wrap_po e',t)} ] unit | _, Ir.ActorE _ -> wrap_po e | _ -> assert false else From e080bcb19dcccee467d27c9640a77a7120e2a9fa Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Thu, 8 Aug 2024 13:48:16 +0200 Subject: [PATCH 056/127] wip --- src/lowering/desugar.ml | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/src/lowering/desugar.ml b/src/lowering/desugar.ml index 71695152462..5bc582de2ab 100644 --- a/src/lowering/desugar.ml +++ b/src/lowering/desugar.ml @@ -236,8 +236,11 @@ and exp' at note = function | S.BreakE (l, e) -> (breakE l.it (exp e)).it | S.RetE e -> (retE (exp e)).it | S.ThrowE e -> I.PrimE (I.ThrowPrim, [exp e]) - | S.AsyncE (_FIXME, s, tb, e) -> - I.AsyncE (recordE [], s, typ_bind tb, exp e, + | S.AsyncE (par_opt, s, tb, e) -> + let par = match par_opt with + | None -> recordE [] + | Some par -> exp par in + I.AsyncE (par, s, typ_bind tb, exp e, match note.Note.typ with | T.Async (_, t, _) -> t | _ -> assert false) From 312093166e06452292a9cd1c78100ea56f058fdc Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Mon, 12 Aug 2024 13:41:55 +0200 Subject: [PATCH 057/127] merge fix --- src/viper/prep.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/viper/prep.ml b/src/viper/prep.ml index 081717183f9..56a88be69b4 100644 --- a/src/viper/prep.ml +++ b/src/viper/prep.ml @@ -39,7 +39,7 @@ let mono_calls_visitor (stk : mono_goal Stack.t) : visitor = let goal = { mg_id = v.it; mg_typs = inst.note } in if goal.mg_typs <> [] then Stack.push goal stk; let s = string_of_mono_goal goal in - {exp with it = CallE(None, {it = VarE (s @@ v_at); at=v_at; note=v_note}, + {exp with it = CallE(None, {it = VarE (s @~ v_at); at=v_at; note=v_note}, {it = None; at=inst.at; note = []}, e)} | e -> e } From cf7cfa4cf69791434b6b1115b5b833a138bf2c9f Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Mon, 12 Aug 2024 14:10:39 +0200 Subject: [PATCH 058/127] fix up test, but legacy should still work --- test/run-drun/actor-class-cycles.mo | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/test/run-drun/actor-class-cycles.mo b/test/run-drun/actor-class-cycles.mo index 06c85db266c..cd9048aaf8a 100644 --- a/test/run-drun/actor-class-cycles.mo +++ b/test/run-drun/actor-class-cycles.mo @@ -19,7 +19,8 @@ actor a { Prim.debugPrint(debug_show({ iteration = i })); Prim.debugPrint(debug_show({ balance = round(Cycles.balance()) })); let c = await { - Cycles.add((i + 1) * 10_000_000_000_000); + //Cycles.add((i + 1) * 10_000_000_000_000); FIXME: this should still work without a parenthetical + (with cycles = (i + 1) * 10_000_000_000_000) Lib.C(); }; let {current = cur; initial = init} = await c.balance(); From 84e42e1ae28ee144a3cb9f4d7565b7816a0fca8d Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Mon, 12 Aug 2024 14:14:22 +0200 Subject: [PATCH 059/127] infer parenthetical but should we ensure that it is `T.Obj`? --- src/mo_frontend/typing.ml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/mo_frontend/typing.ml b/src/mo_frontend/typing.ml index 9ea977beda9..85baaea0599 100644 --- a/src/mo_frontend/typing.ml +++ b/src/mo_frontend/typing.ml @@ -1617,9 +1617,10 @@ and infer_exp'' env exp : T.typ = check_exp_strong env T.throw exp1 end; T.Non - | AsyncE (_, s, typ_bind, exp1) -> + | AsyncE (par_opt, s, typ_bind, exp1) -> error_in Flags.[WASIMode; WasmMode] env exp1.at "M0086" "async expressions are not supported"; + ignore (Option.map (infer_exp env) par_opt); (* TODO: in restricted environment? *) let t1, next_cap = check_AsyncCap env "async expression" exp.at in let c, tb, ce, cs = check_typ_bind env typ_bind in let ce_scope = T.Env.add T.default_scope_var c ce in (* pun scope var with c *) From b3ea1c247ec9bae61a408f50dfd4a434af9313a3 Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Mon, 12 Aug 2024 14:46:31 +0200 Subject: [PATCH 060/127] WIP: test --- test/run-drun/ok/par.drun-run.ok | 2 ++ test/run-drun/par.mo | 48 ++++++++++++++++++++++++++++++++ 2 files changed, 50 insertions(+) create mode 100644 test/run-drun/ok/par.drun-run.ok create mode 100644 test/run-drun/par.mo diff --git a/test/run-drun/ok/par.drun-run.ok b/test/run-drun/ok/par.drun-run.ok new file mode 100644 index 00000000000..a6f776f43c6 --- /dev/null +++ b/test/run-drun/ok/par.drun-run.ok @@ -0,0 +1,2 @@ +ingress Completed: Reply: 0x4449444c016c01b3c4b1f204680100010a00000000000000000101 +ingress Completed: Reply: 0x4449444c0000 diff --git a/test/run-drun/par.mo b/test/run-drun/par.mo new file mode 100644 index 00000000000..f350e3eed92 --- /dev/null +++ b/test/run-drun/par.mo @@ -0,0 +1,48 @@ +actor { + + func foo(next : () -> async ()) : async () { + await (with cycles = 3000) next() + }; + + func bar(next : () -> async ()) : async () = async { + await (with cycles = 4000) next() + }; + + public func oneshot() { + }; + + public func test(): async () { + let message = "Hi!"; + + func closA() : async Nat { + message.size() + }; + + func closB() : async Nat = async { + message.size() + }; +/* + // this is ruled out + func closC() : async Nat = + if (1 == 2) async { + message.size() + } else async { + message.size() + 1 + }; +*/ + assert 42 == 42; + assert 3 == (await (with cycles = 101) closA()); + assert 3 == (await (with cycles = 102) closB()); + + await (with yeah = 8; timeout = 55; cycles = 1000) + foo(func() : async () = async { assert message == "Hi!" }); + await (with cycles = 5000) + bar(func() : async () = async { assert message == "Hi!" }); + }; + + + public func test2() : async () { + await (with cycles = 1042) async { } + + } +} From 6b0d54a21f4cbfbc185b0529fa1cdcb97fe330e0 Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Mon, 12 Aug 2024 16:00:49 +0200 Subject: [PATCH 061/127] handle stacked parenthetials --- src/mo_frontend/parser.mly | 10 +++++----- test/run-drun/ok/par.drun-run.ok | 4 ++++ test/run-drun/par.mo | 21 ++++++++++++++++----- 3 files changed, 25 insertions(+), 10 deletions(-) diff --git a/src/mo_frontend/parser.mly b/src/mo_frontend/parser.mly index 4d0b5080628..6413108b818 100644 --- a/src/mo_frontend/parser.mly +++ b/src/mo_frontend/parser.mly @@ -705,11 +705,11 @@ exp_un(B) : { DebugE(e) @? at $sloc } | LPAR base=exp_post(ob)? WITH fs=seplist(exp_field, semicolon) RPAR e=exp_nest (* parentheticals to qualify message sends *) { match e.it with - | CallE (None, f, is, args) -> - { e with it = CallE (Some (ObjE(Option.to_list base, fs) @? e.at), f, is, args) } - | AsyncE (None, Type.Fut, binds, exp) -> - { e with it = AsyncE (Some (ObjE(Option.to_list base, fs) @? e.at), Type.Fut, binds, exp) } - | _ -> { e with it = ObjE(Option.to_list base, fs) } (* FIXME: meh *) + | CallE (base0_opt, f, is, args) -> + { e with it = CallE (Some (ObjE (Option.(to_list base0_opt @ to_list base), fs) @? e.at), f, is, args) } + | AsyncE (base0_opt, Type.Fut, binds, exp) -> + { e with it = AsyncE (Some (ObjE (Option.(to_list base0_opt @ to_list base), fs) @? e.at), Type.Fut, binds, exp) } + | _ -> e (* FIXME: meh, can we emit a warning? *) } | IF b=exp_nullary(ob) e1=exp_nest %prec IF_NO_ELSE { IfE(b, e1, TupE([]) @? at $sloc) @? at $sloc } diff --git a/test/run-drun/ok/par.drun-run.ok b/test/run-drun/ok/par.drun-run.ok index a6f776f43c6..3bbc00e091b 100644 --- a/test/run-drun/ok/par.drun-run.ok +++ b/test/run-drun/ok/par.drun-run.ok @@ -1,2 +1,6 @@ ingress Completed: Reply: 0x4449444c016c01b3c4b1f204680100010a00000000000000000101 ingress Completed: Reply: 0x4449444c0000 +debug.print: test() +ingress Completed: Reply: 0x4449444c0000 +debug.print: test2() +ingress Completed: Reply: 0x4449444c0000 diff --git a/test/run-drun/par.mo b/test/run-drun/par.mo index f350e3eed92..33b1800159c 100644 --- a/test/run-drun/par.mo +++ b/test/run-drun/par.mo @@ -1,3 +1,6 @@ +import { debugPrint } "mo:⛔"; +import Cycles = "cycles/cycles"; + actor { func foo(next : () -> async ()) : async () { @@ -11,7 +14,8 @@ actor { public func oneshot() { }; - public func test(): async () { + public func test() : async () { + debugPrint "test()"; let message = "Hi!"; func closA() : async Nat { @@ -30,7 +34,6 @@ actor { message.size() + 1 }; */ - assert 42 == 42; assert 3 == (await (with cycles = 101) closA()); assert 3 == (await (with cycles = 102) closB()); @@ -40,9 +43,17 @@ actor { bar(func() : async () = async { assert message == "Hi!" }); }; - public func test2() : async () { - await (with cycles = 1042) async { } - + debugPrint "test2()"; + await (with cycles = 1042) async { assert Cycles.available() == 0/*FIXME: WHY?*/ }; + await (with cycles = 3042) (with cycles = 4042) async { assert Cycles.available() == 0/*FIXME: WHY?*/ }; } } + +// testing +//SKIP run +//SKIP run-ir +//SKIP run-low + +//CALL ingress test "DIDL\x00\x00" +//CALL ingress test2 "DIDL\x00\x00" From ebc89b4132356e9e90b467682fe3b6f780fba04e Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Tue, 13 Aug 2024 14:00:47 +0200 Subject: [PATCH 062/127] WIP: make it an option --- src/ir_def/arrange_ir.ml | 2 +- src/ir_def/construct.ml | 6 +++++- src/ir_def/construct.mli | 1 + src/ir_def/freevars.ml | 2 +- src/ir_def/ir.ml | 2 +- src/ir_def/rename.ml | 2 +- src/ir_passes/await.ml | 2 +- src/ir_passes/eq.ml | 2 +- src/ir_passes/erase_typ_field.ml | 2 +- src/ir_passes/show.ml | 2 +- src/ir_passes/tailcall.ml | 2 +- src/lowering/desugar.ml | 5 +---- 12 files changed, 16 insertions(+), 14 deletions(-) diff --git a/src/ir_def/arrange_ir.ml b/src/ir_def/arrange_ir.ml index 5641bebad1f..480be289600 100644 --- a/src/ir_def/arrange_ir.ml +++ b/src/ir_def/arrange_ir.ml @@ -22,7 +22,7 @@ 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 (par, Type.Fut, tb, e, t) -> "AsyncE" $$ [exp par; 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] diff --git a/src/ir_def/construct.ml b/src/ir_def/construct.ml index c308a9fff89..238a4bfad1f 100644 --- a/src/ir_def/construct.ml +++ b/src/ir_def/construct.ml @@ -320,7 +320,7 @@ let funcE name sort ctrl typ_binds args typs exp = let recordE' = ref (fun _ -> nullE ()) (* gets correctly filled below *) let asyncE s typ_bind e typ1 = - { it = AsyncE (!recordE' [], s, typ_bind, e, typ1); + { it = AsyncE (None, s, typ_bind, e, typ1); at = no_region; note = Note.{ def with typ = T.Async (s, typ1, typ e); @@ -344,6 +344,10 @@ let callE exp1 typs exp2 = } } +let parenthetical par = function + | { it = PrimE (CallPrim (typs, _), es); _ } as e when true -> + { e with it = PrimE (CallPrim (typs, par), es) } + | e -> Printf.eprintf "PAR? %s\n" (Wasm.Sexpr.to_string 180 (Arrange_ir.exp e)); e let ifE exp1 exp2 exp3 = { it = IfE (exp1, exp2, exp3); diff --git a/src/ir_def/construct.mli b/src/ir_def/construct.mli index 3aadc7262bd..db978d1cf75 100644 --- a/src/ir_def/construct.mli +++ b/src/ir_def/construct.mli @@ -144,6 +144,7 @@ val (-->*) : var list -> exp -> exp (* n-ary local *) val forall : typ_bind list -> exp -> exp (* generalization *) val named : string -> exp -> exp (* renaming a function *) val (-*-) : exp -> exp -> exp (* application *) +val parenthetical : exp -> exp -> exp (* Objects *) diff --git a/src/ir_def/freevars.ml b/src/ir_def/freevars.ml index 05319936f2c..8d940002867 100644 --- a/src/ir_def/freevars.ml +++ b/src/ir_def/freevars.ml @@ -112,7 +112,7 @@ let rec exp e : f = match e.it with | SwitchE (e, cs) -> exp e ++ cases cs | LoopE e1 -> exp e1 | LabelE (i, t, e) -> exp e - | AsyncE (par, _, _, e, _) -> exp par ++ exp e + | AsyncE (par, _, _, e, _) -> exps Option.(to_list par) ++ exp e | DeclareE (i, t, e) -> exp e // i | DefineE (i, m, e) -> id i ++ exp e | FuncE (x, s, c, tp, as_, t, e) -> under_lambda (exp e /// args as_) diff --git a/src/ir_def/ir.ml b/src/ir_def/ir.ml index c69365146e0..83fa1a1e7d6 100644 --- a/src/ir_def/ir.ml +++ b/src/ir_def/ir.ml @@ -66,7 +66,7 @@ and exp' = | SwitchE of exp * case list (* switch *) | LoopE of exp (* do-while loop *) | LabelE of id * Type.typ * exp (* label *) - | AsyncE of exp * Type.async_sort * typ_bind * exp * Type.typ (* async/async* *) + | AsyncE of exp option * Type.async_sort * typ_bind * exp * Type.typ (* async/async* *) | DeclareE of id * Type.typ * exp (* local promise *) | DefineE of id * mut * exp (* promise fulfillment *) | FuncE of (* function *) diff --git a/src/ir_def/rename.ml b/src/ir_def/rename.ml index 7aedc18dde0..48e2520d5f5 100644 --- a/src/ir_def/rename.ml +++ b/src/ir_def/rename.ml @@ -54,7 +54,7 @@ and exp' rho = function | LoopE e1 -> LoopE (exp rho e1) | LabelE (i, t, e) -> let i',rho' = id_bind rho i in LabelE(i', t, exp rho' e) - | AsyncE (par, s, tb, e, t) -> AsyncE (exp rho par, s, tb, exp rho e, t) + | AsyncE (par, s, tb, e, t) -> AsyncE (Option.map (exp rho) par, s, tb, exp rho e, t) | DeclareE (i, t, e) -> let i',rho' = id_bind rho i in DeclareE (i', t, exp rho' e) | DefineE (i, m, e) -> DefineE (id rho i, m, exp rho e) diff --git a/src/ir_passes/await.ml b/src/ir_passes/await.ml index 663bcf7c522..3dd7ba2a924 100644 --- a/src/ir_passes/await.ml +++ b/src/ir_passes/await.ml @@ -433,7 +433,7 @@ and c_exp' context exp k = end | AsyncE (_, T.Cmp, tb, exp1, typ1) -> assert false (* must have effect T.Triv, handled by first case *) - | AsyncE (_FIXME, T.Fut, tb, exp1, typ1) -> + | AsyncE (par, T.Fut, tb, exp1, typ1) -> (* add the implicit return label *) let k_ret = fresh_cont (typ exp1) T.unit in let k_fail = fresh_err_cont T.unit in diff --git a/src/ir_passes/eq.ml b/src/ir_passes/eq.ml index 3354f23bbba..afce6ab0dcb 100644 --- a/src/ir_passes/eq.ml +++ b/src/ir_passes/eq.ml @@ -240,7 +240,7 @@ and t_exp' env = function LoopE (t_exp env exp1) | LabelE (id, typ, exp1) -> LabelE (id, typ, t_exp env exp1) - | AsyncE (par, s, tb, e, typ) -> AsyncE (t_exp env par, s, tb, t_exp env e, typ) + | AsyncE (par, s, tb, e, typ) -> AsyncE (Option.map (t_exp env) par, s, tb, t_exp env e, typ) | DeclareE (id, typ, exp1) -> DeclareE (id, typ, t_exp env exp1) | DefineE (id, mut ,exp1) -> diff --git a/src/ir_passes/erase_typ_field.ml b/src/ir_passes/erase_typ_field.ml index afc4f22282f..db6161714bc 100644 --- a/src/ir_passes/erase_typ_field.ml +++ b/src/ir_passes/erase_typ_field.ml @@ -118,7 +118,7 @@ let transform prog = | LabelE (id, typ, exp1) -> LabelE (id, t_typ typ, t_exp exp1) | AsyncE (par, s, tb, exp1, typ) -> - AsyncE (t_exp par, s, t_typ_bind tb, t_exp exp1, t_typ typ) + AsyncE (Option.map t_exp par, s, t_typ_bind tb, t_exp exp1, t_typ typ) | TryE (exp1, cases, vt) -> TryE (t_exp exp1, List.map t_case cases, vt) | DeclareE (id, typ, exp1) -> diff --git a/src/ir_passes/show.ml b/src/ir_passes/show.ml index 1fde7b3a819..5fa35405b59 100644 --- a/src/ir_passes/show.ml +++ b/src/ir_passes/show.ml @@ -282,7 +282,7 @@ and t_exp' env = function LoopE (t_exp env exp1) | LabelE (id, typ, exp1) -> LabelE (id, typ, t_exp env exp1) - | AsyncE (par, s, tb, e, typ) -> AsyncE (t_exp env par, s, tb, t_exp env e, typ) + | AsyncE (par, s, tb, e, typ) -> AsyncE (Option.map (t_exp env) par, s, tb, t_exp env e, typ) | DeclareE (id, typ, exp1) -> DeclareE (id, typ, t_exp env exp1) | DefineE (id, mut ,exp1) -> diff --git a/src/ir_passes/tailcall.ml b/src/ir_passes/tailcall.ml index 980970deb8c..52152356a74 100644 --- a/src/ir_passes/tailcall.ml +++ b/src/ir_passes/tailcall.ml @@ -111,7 +111,7 @@ and exp' env e : exp' = match e.it with | LabelE (i, t, e) -> let env1 = bind env i None in LabelE(i, t, exp env1 e) | PrimE (RetPrim, [e])-> PrimE (RetPrim, [tailexp { env with tail_pos = true } e]) - | AsyncE (par, s, tb, e, typ) -> AsyncE (exp env par, s, tb, exp { tail_pos = true; info = None } e, typ) + | AsyncE (par, s, tb, e, typ) -> AsyncE (Option.map (exp env) par, s, tb, exp { tail_pos = true; info = None } e, typ) | DeclareE (i, t, e) -> let env1 = bind env i None in DeclareE (i, t, tailexp env1 e) | DefineE (i, m, e) -> DefineE (i, m, exp env e) diff --git a/src/lowering/desugar.ml b/src/lowering/desugar.ml index 5bc582de2ab..030addcb07a 100644 --- a/src/lowering/desugar.ml +++ b/src/lowering/desugar.ml @@ -237,10 +237,7 @@ and exp' at note = function | S.RetE e -> (retE (exp e)).it | S.ThrowE e -> I.PrimE (I.ThrowPrim, [exp e]) | S.AsyncE (par_opt, s, tb, e) -> - let par = match par_opt with - | None -> recordE [] - | Some par -> exp par in - I.AsyncE (par, s, typ_bind tb, exp e, + I.AsyncE (Option.map exp par_opt, s, typ_bind tb, exp e, match note.Note.typ with | T.Async (_, t, _) -> t | _ -> assert false) From 82f20494f51b23e8b4718f33881886d672503ccf Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Tue, 13 Aug 2024 18:27:05 +0200 Subject: [PATCH 063/127] WIP: thread parentheticals through for `async` --- src/ir_passes/await.ml | 12 ++++++++---- test/run-drun/par.mo | 4 ++-- 2 files changed, 10 insertions(+), 6 deletions(-) diff --git a/src/ir_passes/await.ml b/src/ir_passes/await.ml index 3dd7ba2a924..8e577c48a58 100644 --- a/src/ir_passes/await.ml +++ b/src/ir_passes/await.ml @@ -88,7 +88,7 @@ let typ_cases cases = List.fold_left (fun t case -> T.lub t (typ case.it.exp)) T let rec t_async context exp = match exp.it with - | AsyncE (_FIXME, s, tb, exp1, typ1) -> + | AsyncE (par_opt, s, tb, exp1, typ1) -> let exp1 = R.exp R.Renaming.empty exp1 in (* rename all bound vars apart *) (*Why?*) (* add the implicit return label *) let k_ret = fresh_cont (typ exp1) T.unit in @@ -99,7 +99,9 @@ let rec t_async context exp = (LabelEnv.add Return (Cont k_ret) (LabelEnv.singleton Throw (Cont k_fail))) in - cps_asyncE s typ1 (primE ICCyclesPrim []) (typ exp1) + cps_asyncE s typ1 (match par_opt with + | Some par -> assert false; optE par + | None -> primE ICCyclesPrim []) (typ exp1) (forall [tb] ([k_ret; k_fail; k_clean] -->* (c_exp context' exp1 (ContVar k_ret)))) | _ -> assert false @@ -433,7 +435,7 @@ and c_exp' context exp k = end | AsyncE (_, T.Cmp, tb, exp1, typ1) -> assert false (* must have effect T.Triv, handled by first case *) - | AsyncE (par, T.Fut, tb, exp1, typ1) -> + | AsyncE (par_opt, T.Fut, tb, exp1, typ1) -> (* add the implicit return label *) let k_ret = fresh_cont (typ exp1) T.unit in let k_fail = fresh_err_cont T.unit in @@ -448,7 +450,9 @@ and c_exp' context exp k = | _ -> assert false in let cps_async = - cps_asyncE T.Fut typ1 (primE ICCyclesPrim []) (typ exp1) + cps_asyncE T.Fut typ1 (match par_opt with + | Some par -> optE par + | None -> primE ICCyclesPrim []) (typ exp1) (forall [tb] ([k_ret; k_fail; k_clean] -->* (c_exp context' exp1 (ContVar k_ret)))) in let k' = meta (typ cps_async) diff --git a/test/run-drun/par.mo b/test/run-drun/par.mo index 33b1800159c..60a1bcb03a1 100644 --- a/test/run-drun/par.mo +++ b/test/run-drun/par.mo @@ -45,8 +45,8 @@ actor { public func test2() : async () { debugPrint "test2()"; - await (with cycles = 1042) async { assert Cycles.available() == 0/*FIXME: WHY?*/ }; - await (with cycles = 3042) (with cycles = 4042) async { assert Cycles.available() == 0/*FIXME: WHY?*/ }; + await (with cycles = 1042) async { assert Cycles.available() == 1042 }; + await (with cycles = 3042) (with cycles = 4042) async { assert Cycles.available() == 3042/*FIXME: WHY?*/ }; } } From a7d2874bb0ad32a3022bfd5bee2eae843d8f458b Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Tue, 13 Aug 2024 18:38:01 +0200 Subject: [PATCH 064/127] make sure that the record has a `cycles` field --- src/ir_passes/await.ml | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/src/ir_passes/await.ml b/src/ir_passes/await.ml index 8e577c48a58..ddd3896e7cf 100644 --- a/src/ir_passes/await.ml +++ b/src/ir_passes/await.ml @@ -451,8 +451,10 @@ and c_exp' context exp k = in let cps_async = cps_asyncE T.Fut typ1 (match par_opt with - | Some par -> optE par - | None -> primE ICCyclesPrim []) (typ exp1) + | Some par when T.(sub (typ par) (Obj (Object, [{ lab = "cycles"; typ = nat; src = empty_src}]))) + -> optE par + | None -> primE ICCyclesPrim [] + | Some _ -> nullE ()) (typ exp1) (forall [tb] ([k_ret; k_fail; k_clean] -->* (c_exp context' exp1 (ContVar k_ret)))) in let k' = meta (typ cps_async) From b482532c3bc9f97389225b3f81000bd294a6ec6f Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Wed, 14 Aug 2024 13:04:21 +0200 Subject: [PATCH 065/127] maybe we should rule this out it crashes the compiler but other type of metadata could be useful here --- test/run-drun/par.mo | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/test/run-drun/par.mo b/test/run-drun/par.mo index 60a1bcb03a1..f3596ea982e 100644 --- a/test/run-drun/par.mo +++ b/test/run-drun/par.mo @@ -34,6 +34,13 @@ actor { message.size() + 1 }; */ + +/* //Rule this out? + func closD() : async Nat = (with cycles = 765) async { + message.size() + }; +*/ + assert 3 == (await (with cycles = 101) closA()); assert 3 == (await (with cycles = 102) closB()); From 13b46f6236773ffdcfc2cdc9fb13ac8b042d91c4 Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Wed, 14 Aug 2024 13:13:29 +0200 Subject: [PATCH 066/127] remove FIXMEs --- src/mo_frontend/effect.ml | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/mo_frontend/effect.ml b/src/mo_frontend/effect.ml index 064ef93044a..a989d62ac21 100644 --- a/src/mo_frontend/effect.ml +++ b/src/mo_frontend/effect.ml @@ -49,8 +49,10 @@ let effect_exp (exp:Syntax.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:Syntax.exp) : T.eff = match exp.it with - | CallE (_FIXME, exp1, inst, exp2) when is_async_call exp1 inst exp2 -> + | CallE (_, exp1, inst, exp2) when is_async_call exp1 inst exp2 -> T.Await + | CallE (Some par, exp1, _, exp2) -> + map_max_effs effect_exp [par; exp1; exp2] | PrimE _ | VarE _ | LitE _ @@ -81,16 +83,14 @@ let rec infer_effect_exp (exp:Syntax.exp) : T.eff = | IdxE (exp1, exp2) | RelE (_, exp1, _, exp2) | AssignE (exp1, exp2) - | CallE (_(*FIXME*), exp1, _, exp2) + | CallE (None, exp1, _, exp2) | AndE (exp1, exp2) | OrE (exp1, exp2) | ImpliesE (exp1, exp2) | WhileE (exp1, exp2) | LoopE (exp1, Some exp2) | ForE (_, exp1, exp2) -> - let t1 = effect_exp exp1 in - let t2 = effect_exp exp2 in - max_eff t1 t2 + map_max_effs effect_exp [exp1; exp2] | DebugE exp1 -> effect_exp exp1 | ToCandidE exps From b5f98a92193af84c5e25e834dd3b427707a2f513 Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Wed, 14 Aug 2024 13:19:51 +0200 Subject: [PATCH 067/127] elim FIXMEs --- src/mo_frontend/definedness.ml | 27 ++++++++++++++------------- 1 file changed, 14 insertions(+), 13 deletions(-) diff --git a/src/mo_frontend/definedness.ml b/src/mo_frontend/definedness.ml index 3cd5dfe4960..71dbaf25779 100644 --- a/src/mo_frontend/definedness.ml +++ b/src/mo_frontend/definedness.ml @@ -82,7 +82,7 @@ let rec exp msgs e : f = match e.it with (* Eager uses are either first-class uses of a variable: *) | VarE i -> M.singleton i.it Eager (* Or anything that is occurring in a call (as this may call a closure): *) - | CallE (_FIXME, e1, ts, e2) -> eagerify (exps msgs [e1; e2]) + | CallE (par_opt, e1, _ts, e2) -> eagerify (Option.to_list par_opt @ [e1; e2] |> exps msgs) (* And break, return, throw can be thought of as calling a continuation: *) | BreakE (i, e) -> eagerify (exp msgs e) | RetE e -> eagerify (exp msgs e) @@ -111,8 +111,8 @@ let rec exp msgs e : f = match e.it with | IdxE (e1, e2) -> exps msgs [e1; e2] | BlockE ds -> group msgs (decs msgs ds) | NotE e -> exp msgs e - | AndE (e1, e2) -> exps msgs [e1; e2] - | OrE (e1, e2) -> exps msgs [e1; e2] + | AndE (e1, e2) + | OrE (e1, e2) | ImpliesE (e1, e2) -> exps msgs [e1; e2] | OldE e -> exp msgs e | IfE (e1, e2, e3) -> exps msgs [e1; e2; e3] @@ -123,16 +123,17 @@ let rec exp msgs e : f = match e.it with | LoopE (e1, None) -> exp msgs e1 | LoopE (e1, Some e2) -> exps msgs [e1; e2] | ForE (p, e1, e2) -> exp msgs e1 ++ (exp msgs e2 /// pat msgs p) - | LabelE (i, t, e) -> exp msgs e - | DebugE e -> exp msgs e - | AsyncE (_FIXME, _, _, e) -> exp msgs e - | AwaitE (_, e) -> exp msgs e - | AssertE (_, e) -> exp msgs e - | AnnotE (e, t) -> exp msgs e - | OptE e -> exp msgs e - | DoOptE e -> exp msgs e - | BangE e -> exp msgs e - | TagE (_, e) -> exp msgs e + | AsyncE (Some par, _, _, e) -> exps msgs [par; e] + | LabelE (_, _, e) + | DebugE e + | AsyncE (None, _, _, e) + | AwaitE (_, e) + | AssertE (_, e) + | AnnotE (e, _) + | OptE e + | DoOptE e + | BangE e + | TagE (_, e) | IgnoreE e -> exp msgs e and exps msgs es : f = unions (exp msgs) es From 19e8058d8bd13633fb544441542ff8d4d4a257f8 Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Wed, 14 Aug 2024 14:14:37 +0200 Subject: [PATCH 068/127] elim FIXMEs --- src/mo_def/arrange.ml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/mo_def/arrange.ml b/src/mo_def/arrange.ml index 7dc899d9c79..06303934b43 100644 --- a/src/mo_def/arrange.ml +++ b/src/mo_def/arrange.ml @@ -87,7 +87,8 @@ module Make (Cfg : Config) = struct Atom (if sugar then "" else "="); exp e' ] - | CallE (_FIXME, e1, ts, e2) -> "CallE" $$ [exp e1] @ inst ts @ [exp e2] + | CallE (None, e1, ts, e2) -> "CallE" $$ [exp e1] @ inst ts @ [exp e2] + | CallE (Some par, e1, ts, e2) -> "CallE()" $$ [exp par] @ [exp e1] @ inst ts @ [exp e2] | BlockE ds -> "BlockE" $$ List.map dec ds | NotE e -> "NotE" $$ [exp e] | AndE (e1, e2) -> "AndE" $$ [exp e1; exp e2] From a0e321d0ab549ad158eb6b0cf89fd427a7ed9fd3 Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Wed, 14 Aug 2024 16:46:35 +0200 Subject: [PATCH 069/127] elim FIXMEs not completely sure --- src/ir_passes/const.ml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/ir_passes/const.ml b/src/ir_passes/const.ml index e340dc3422c..142bb63af30 100644 --- a/src/ir_passes/const.ml +++ b/src/ir_passes/const.ml @@ -147,7 +147,8 @@ let rec exp lvl (env : env) e : Lbool.t = exp_ lvl env e2; exp_ lvl env e3; surely_false - | SelfCallE (_FIXME, _, e1, e2, e3, e4) -> + | SelfCallE (par, _, e1, e2, e3, e4) -> + exp_ lvl env par; exp_ NotTopLvl env e1; exp_ lvl env e2; exp_ lvl env e3; From d147896eece6da1ba3e7221cf3c896fcc1ee7568 Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Wed, 14 Aug 2024 16:49:18 +0200 Subject: [PATCH 070/127] elim FIXMEs --- src/ir_def/rename.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/ir_def/rename.ml b/src/ir_def/rename.ml index 48e2520d5f5..76f5ce9823b 100644 --- a/src/ir_def/rename.ml +++ b/src/ir_def/rename.ml @@ -64,8 +64,8 @@ and exp' rho = function FuncE (x, s, c, tp, p', ts, e') | NewObjE (s, fs, t) -> NewObjE (s, fields rho fs, t) | TryE (e, cs, cl) -> TryE (exp rho e, cases rho cs, Option.map (fun (v, t) -> id rho v, t) cl) - | SelfCallE (_FIXME, ts, e1, e2, e3, e4) -> - SelfCallE (_FIXME, ts, exp rho e1, exp rho e2, exp rho e3, exp rho e4) + | SelfCallE (par, ts, e1, e2, e3, e4) -> + SelfCallE (exp rho par, ts, exp rho e1, exp rho e2, exp rho e3, exp rho e4) and lexp rho le = {le with it = lexp' rho le.it} and lexp' rho = function From a23f97a9de8867f7f084b7a64dc1d4b4468c444d Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Wed, 14 Aug 2024 16:56:32 +0200 Subject: [PATCH 071/127] elim FIXMEs --- src/ir_def/ir_effect.ml | 10 +++------- 1 file changed, 3 insertions(+), 7 deletions(-) diff --git a/src/ir_def/ir_effect.ml b/src/ir_def/ir_effect.ml index 46d412d67f7..14f61b049be 100644 --- a/src/ir_def/ir_effect.ml +++ b/src/ir_def/ir_effect.ml @@ -81,13 +81,9 @@ and infer_effect_exp (exp: exp) : T.eff = effect_exp exp1 | FuncE _ -> T.Triv - | SelfCallE (_FIXME, _, _, exp1, exp2, exp3) -> - let e1 = effect_exp exp1 in - let e2 = effect_exp exp2 in - let e3 = effect_exp exp3 in - max_eff e1 (max_eff e2 e3) - | ActorE _ -> - T.Triv + | SelfCallE (par, _, _, exp1, exp2, exp3) -> + map_max_effs effect_exp [par; exp1; exp2; exp3] + | ActorE _ | NewObjE _ -> T.Triv From c475dc73398750b70a2eb31245fdfeeb3b42e1d1 Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Wed, 14 Aug 2024 17:34:44 +0200 Subject: [PATCH 072/127] tweak --- src/ir_def/ir_effect.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/ir_def/ir_effect.ml b/src/ir_def/ir_effect.ml index 14f61b049be..e03a82ca8ff 100644 --- a/src/ir_def/ir_effect.ml +++ b/src/ir_def/ir_effect.ml @@ -98,7 +98,7 @@ and effect_cases cases = and effect_dec dec = match dec.it with | LetD (_, e) | VarD (_, _, e) -> effect_exp e | RefD (_, _, { it = DotLE (e, _); _ }) -> effect_exp e - | RefD (_, _, _) -> assert false + | RefD _ -> assert false let infer_effect_dec = effect_dec From 58c81b9830ec3aaf076dce64fdfb4ab2adbbf9ab Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Wed, 14 Aug 2024 17:43:42 +0200 Subject: [PATCH 073/127] elim FIXMEs --- src/ir_def/freevars.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/ir_def/freevars.ml b/src/ir_def/freevars.ml index 8d940002867..4dd5be42fbe 100644 --- a/src/ir_def/freevars.ml +++ b/src/ir_def/freevars.ml @@ -119,7 +119,7 @@ let rec exp e : f = match e.it with | ActorE (ds, fs, u, _) -> actor ds fs u | NewObjE (_, fs, _) -> fields fs | TryE (e, cs, cl) -> exp e ++ cases cs ++ (match cl with Some (v, _) -> id v | _ -> M.empty) - | SelfCallE (_FIXME, _, e1, e2, e3, e4) -> under_lambda (exp e1) ++ exps [e2; e3; e4] + | SelfCallE (par, _, e1, e2, e3, e4) -> under_lambda (exp e1) ++ exps [par; e2; e3; e4] and actor ds fs u = close (decs ds +++ fields fs +++ system u) From 498dd9be34fe303a015164d59789c5baf471a888 Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Wed, 14 Aug 2024 18:29:47 +0200 Subject: [PATCH 074/127] elim FIXMEs MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit tryin' my best… --- src/ir_passes/tailcall.ml | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/src/ir_passes/tailcall.ml b/src/ir_passes/tailcall.ml index 52152356a74..70dbb8c2795 100644 --- a/src/ir_passes/tailcall.ml +++ b/src/ir_passes/tailcall.ml @@ -120,13 +120,14 @@ and exp' env e : exp' = match e.it with let env2 = args env1 as_ in let exp0' = tailexp env2 exp0 in FuncE (x, s, c, tbs, as_, ret_tys, exp0') - | SelfCallE (_FIXME, ts, exp1, exp2, exp3, exp4) -> - let env1 = { tail_pos = true; info = None} in + | SelfCallE (par, ts, exp1, exp2, exp3, exp4) -> + let par' = exp env par in + let env1 = { tail_pos = true; info = None } in let exp1' = tailexp env1 exp1 in let exp2' = exp env exp2 in let exp3' = exp env exp3 in let exp4' = exp env exp4 in - SelfCallE (_FIXME, ts, exp1', exp2', exp3', exp4') + SelfCallE (par', ts, exp1', exp2', exp3', exp4') | ActorE (ds, fs, u, t) -> let u = { u with preupgrade = exp env u.preupgrade; postupgrade = exp env u.postupgrade } in ActorE (snd (decs env ds), fs, u, t) From 65013fae533ed959ae60ff08974c30d3d3591b9d Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Tue, 22 Oct 2024 15:32:22 +0200 Subject: [PATCH 075/127] add `M0200` --- src/lang_utils/error_codes.ml | 1 + src/lang_utils/error_codes/M0200.md | 9 +++++++++ 2 files changed, 10 insertions(+) create mode 100644 src/lang_utils/error_codes/M0200.md diff --git a/src/lang_utils/error_codes.ml b/src/lang_utils/error_codes.ml index 16cbd291704..6d3d739d7ad 100644 --- a/src/lang_utils/error_codes.ml +++ b/src/lang_utils/error_codes.ml @@ -203,4 +203,5 @@ let error_codes : (string * string option) list = "M0197", Some([%blob "lang_utils/error_codes/M0197.md"]); (* `system` capability required *) "M0198", Some([%blob "lang_utils/error_codes/M0198.md"]); (* Unused field pattern warning *) "M0199", Some([%blob "lang_utils/error_codes/M0199.md"]); (* Deprecate experimental stable memory *) + "M0200", Some([%blob "lang_utils/error_codes/M0200.md"]); (* Unrecognised attribute in parenthetical note *) ] diff --git a/src/lang_utils/error_codes/M0200.md b/src/lang_utils/error_codes/M0200.md new file mode 100644 index 00000000000..31d35d0321d --- /dev/null +++ b/src/lang_utils/error_codes/M0200.md @@ -0,0 +1,9 @@ +# M0200 + +This warning means that you are affixing a parenthetical note to a message send (i.e. either +a canister method call of a self-send with `async`) that contains an attribute not recognised +by this version of the Motoko compiler. + +Currently following attributes are recognised in parenthetical notes: + +- `cycles : Nat` From 2f179ec89cedd3d3eac581592c5c528d165e5af1 Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Tue, 22 Oct 2024 18:18:32 +0200 Subject: [PATCH 076/127] start with a coarse warning --- src/mo_frontend/typing.ml | 9 +++++++-- test/run-drun/ok/actor-class-cycles.tc.ok | 1 + 2 files changed, 8 insertions(+), 2 deletions(-) create mode 100644 test/run-drun/ok/actor-class-cycles.tc.ok diff --git a/src/mo_frontend/typing.ml b/src/mo_frontend/typing.ml index 669411bde18..23b04f332c5 100644 --- a/src/mo_frontend/typing.ml +++ b/src/mo_frontend/typing.ml @@ -1585,8 +1585,13 @@ and infer_exp'' env exp : T.typ = end; let ts1 = match pat.it with TupP _ -> T.seq_of_tup t1 | _ -> [t1] in T.Func (sort, c, T.close_binds cs tbs, List.map (T.close cs) ts1, List.map (T.close cs) ts2) - | CallE (_FIXME, exp1, inst, exp2) -> - ignore (Option.map (infer_exp env) _FIXME); + | CallE (par_opt, exp1, inst, exp2) -> + let attrs_opt = Option.map (infer_exp env) par_opt in + if not env.pre then begin match attrs_opt with + | None -> () + | Some attrs -> + warn env (Option.get par_opt).at "M0200" "unrecognised attribute in parenthetical note" + end; infer_call env exp1 inst exp2 exp.at None | BlockE decs -> let t, _ = infer_block env decs exp.at false in diff --git a/test/run-drun/ok/actor-class-cycles.tc.ok b/test/run-drun/ok/actor-class-cycles.tc.ok new file mode 100644 index 00000000000..b2b4ad19c1e --- /dev/null +++ b/test/run-drun/ok/actor-class-cycles.tc.ok @@ -0,0 +1 @@ +actor-class-cycles.mo:24.2-24.9: warning [M0200], unrecognised attribute in parenthetical note From 2f938cbf28b40b56566cf9628e47fb96d0c4151f Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Wed, 23 Oct 2024 11:30:23 +0200 Subject: [PATCH 077/127] say what attribute is it --- src/mo_frontend/typing.ml | 6 ++++-- test/run-drun/ok/actor-class-cycles.tc.ok | 1 - 2 files changed, 4 insertions(+), 3 deletions(-) delete mode 100644 test/run-drun/ok/actor-class-cycles.tc.ok diff --git a/src/mo_frontend/typing.ml b/src/mo_frontend/typing.ml index 23b04f332c5..d76e4baf685 100644 --- a/src/mo_frontend/typing.ml +++ b/src/mo_frontend/typing.ml @@ -1590,7 +1590,9 @@ and infer_exp'' env exp : T.typ = if not env.pre then begin match attrs_opt with | None -> () | Some attrs -> - warn env (Option.get par_opt).at "M0200" "unrecognised attribute in parenthetical note" + let [@warning "-8"] T.Object, attrs_flds = T.as_obj attrs in + let unrecognised = List.(filter (fun {T.lab; _} -> lab <> "cycles") attrs_flds |> map (fun {T.lab; _} -> lab)) in + if unrecognised <> [] then warn env (Option.get par_opt).at "M0200" "unrecognised attribute %s in parenthetical note" (List.hd unrecognised) end; infer_call env exp1 inst exp2 exp.at None | BlockE decs -> @@ -2800,7 +2802,7 @@ and infer_val_path env exp : T.typ option = | _ -> None ) | AnnotE (_, typ) -> - Some (check_typ {env with pre = true} typ) + Some (check_typ {env with pre = true} typ) | _ -> None diff --git a/test/run-drun/ok/actor-class-cycles.tc.ok b/test/run-drun/ok/actor-class-cycles.tc.ok deleted file mode 100644 index b2b4ad19c1e..00000000000 --- a/test/run-drun/ok/actor-class-cycles.tc.ok +++ /dev/null @@ -1 +0,0 @@ -actor-class-cycles.mo:24.2-24.9: warning [M0200], unrecognised attribute in parenthetical note From 38fb28c1343a872ce03fc289a0631d5032f48e68 Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Wed, 23 Oct 2024 12:12:05 +0200 Subject: [PATCH 078/127] check `cycles` attribute type --- src/lang_utils/error_codes.ml | 1 + src/mo_frontend/typing.ml | 11 +++++++++-- test/fail/cycle-type.mo | 5 +++++ test/fail/ok/cycle-type.tc.ok | 2 ++ test/fail/ok/cycle-type.tc.ret.ok | 1 + 5 files changed, 18 insertions(+), 2 deletions(-) create mode 100644 test/fail/cycle-type.mo create mode 100644 test/fail/ok/cycle-type.tc.ok create mode 100644 test/fail/ok/cycle-type.tc.ret.ok diff --git a/src/lang_utils/error_codes.ml b/src/lang_utils/error_codes.ml index 6d3d739d7ad..f356a27c3bb 100644 --- a/src/lang_utils/error_codes.ml +++ b/src/lang_utils/error_codes.ml @@ -204,4 +204,5 @@ let error_codes : (string * string option) list = "M0198", Some([%blob "lang_utils/error_codes/M0198.md"]); (* Unused field pattern warning *) "M0199", Some([%blob "lang_utils/error_codes/M0199.md"]); (* Deprecate experimental stable memory *) "M0200", Some([%blob "lang_utils/error_codes/M0200.md"]); (* Unrecognised attribute in parenthetical note *) + "M0201", None; (* `cycle` attribute in parenthetical note must be of type `Nat` *) ] diff --git a/src/mo_frontend/typing.ml b/src/mo_frontend/typing.ml index d76e4baf685..82f66c645d5 100644 --- a/src/mo_frontend/typing.ml +++ b/src/mo_frontend/typing.ml @@ -1587,12 +1587,19 @@ and infer_exp'' env exp : T.typ = T.Func (sort, c, T.close_binds cs tbs, List.map (T.close cs) ts1, List.map (T.close cs) ts2) | CallE (par_opt, exp1, inst, exp2) -> let attrs_opt = Option.map (infer_exp env) par_opt in - if not env.pre then begin match attrs_opt with + if not env.pre + then begin match attrs_opt with | None -> () | Some attrs -> let [@warning "-8"] T.Object, attrs_flds = T.as_obj attrs in let unrecognised = List.(filter (fun {T.lab; _} -> lab <> "cycles") attrs_flds |> map (fun {T.lab; _} -> lab)) in - if unrecognised <> [] then warn env (Option.get par_opt).at "M0200" "unrecognised attribute %s in parenthetical note" (List.hd unrecognised) + if unrecognised <> [] then warn env (Option.get par_opt).at "M0200" "unrecognised attribute %s in parenthetical note" (List.hd unrecognised); + (*check_exp_strong env T.bool {(Option.get par_opt) with note = empty_typ_note}*) + let cyc = List.(filter (fun {T.lab; _} -> lab = "cycles") attrs_flds) in + if cyc <> [] && not T.(sub (List.hd cyc).typ nat) then + local_error env (Option.get par_opt).at "M0201" + "expected Nat type for attribute cycles, but it has type%a" + display_typ_expand (List.hd cyc).T.typ end; infer_call env exp1 inst exp2 exp.at None | BlockE decs -> diff --git a/test/fail/cycle-type.mo b/test/fail/cycle-type.mo new file mode 100644 index 00000000000..ae2e9e9288f --- /dev/null +++ b/test/fail/cycle-type.mo @@ -0,0 +1,5 @@ +actor { + func _bad(a : actor { foo : () -> async () }) : async () { + await (with cycles = 'C') a.foo() + } +} diff --git a/test/fail/ok/cycle-type.tc.ok b/test/fail/ok/cycle-type.tc.ok new file mode 100644 index 00000000000..2d901aca1f6 --- /dev/null +++ b/test/fail/ok/cycle-type.tc.ok @@ -0,0 +1,2 @@ +cycle-type.mo:3.31-3.38: type error [M0201], expected Nat type for attribute cycles, but it has type + Char diff --git a/test/fail/ok/cycle-type.tc.ret.ok b/test/fail/ok/cycle-type.tc.ret.ok new file mode 100644 index 00000000000..69becfa16f9 --- /dev/null +++ b/test/fail/ok/cycle-type.tc.ret.ok @@ -0,0 +1 @@ +Return code 1 From 031c3751cbb7c1ba9a04ec253624ade64f6a5efa Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Wed, 23 Oct 2024 12:14:20 +0200 Subject: [PATCH 079/127] cleanup --- src/mo_frontend/typing.ml | 1 - 1 file changed, 1 deletion(-) diff --git a/src/mo_frontend/typing.ml b/src/mo_frontend/typing.ml index 82f66c645d5..69cd6afbf58 100644 --- a/src/mo_frontend/typing.ml +++ b/src/mo_frontend/typing.ml @@ -1594,7 +1594,6 @@ and infer_exp'' env exp : T.typ = let [@warning "-8"] T.Object, attrs_flds = T.as_obj attrs in let unrecognised = List.(filter (fun {T.lab; _} -> lab <> "cycles") attrs_flds |> map (fun {T.lab; _} -> lab)) in if unrecognised <> [] then warn env (Option.get par_opt).at "M0200" "unrecognised attribute %s in parenthetical note" (List.hd unrecognised); - (*check_exp_strong env T.bool {(Option.get par_opt) with note = empty_typ_note}*) let cyc = List.(filter (fun {T.lab; _} -> lab = "cycles") attrs_flds) in if cyc <> [] && not T.(sub (List.hd cyc).typ nat) then local_error env (Option.get par_opt).at "M0201" From ac6928cf53f3c4c412a668b31a3c186abf962b79 Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Wed, 23 Oct 2024 13:17:45 +0200 Subject: [PATCH 080/127] validate `async` exprs too --- src/mo_frontend/typing.ml | 30 +++++++++++++++--------------- test/fail/cycle-type.mo | 3 ++- test/fail/ok/cycle-type.tc.ok | 2 ++ 3 files changed, 19 insertions(+), 16 deletions(-) diff --git a/src/mo_frontend/typing.ml b/src/mo_frontend/typing.ml index 69cd6afbf58..e519edd72bc 100644 --- a/src/mo_frontend/typing.ml +++ b/src/mo_frontend/typing.ml @@ -1586,20 +1586,7 @@ and infer_exp'' env exp : T.typ = let ts1 = match pat.it with TupP _ -> T.seq_of_tup t1 | _ -> [t1] in T.Func (sort, c, T.close_binds cs tbs, List.map (T.close cs) ts1, List.map (T.close cs) ts2) | CallE (par_opt, exp1, inst, exp2) -> - let attrs_opt = Option.map (infer_exp env) par_opt in - if not env.pre - then begin match attrs_opt with - | None -> () - | Some attrs -> - let [@warning "-8"] T.Object, attrs_flds = T.as_obj attrs in - let unrecognised = List.(filter (fun {T.lab; _} -> lab <> "cycles") attrs_flds |> map (fun {T.lab; _} -> lab)) in - if unrecognised <> [] then warn env (Option.get par_opt).at "M0200" "unrecognised attribute %s in parenthetical note" (List.hd unrecognised); - let cyc = List.(filter (fun {T.lab; _} -> lab = "cycles") attrs_flds) in - if cyc <> [] && not T.(sub (List.hd cyc).typ nat) then - local_error env (Option.get par_opt).at "M0201" - "expected Nat type for attribute cycles, but it has type%a" - display_typ_expand (List.hd cyc).T.typ - end; + if not env.pre then validate_parenthetical env par_opt; infer_call env exp1 inst exp2 exp.at None | BlockE decs -> let t, _ = infer_block env decs exp.at false in @@ -1731,7 +1718,7 @@ and infer_exp'' env exp : T.typ = | AsyncE (par_opt, s, typ_bind, exp1) -> error_in Flags.[WASIMode; WasmMode] env exp1.at "M0086" "async expressions are not supported"; - ignore (Option.map (infer_exp env) par_opt); (* TODO: in restricted environment? *) + if not env.pre then validate_parenthetical env par_opt; (* TODO: in restricted environment? *) let t1, next_cap = check_AsyncCap env "async expression" exp.at in let c, tb, ce, cs = check_typ_bind env typ_bind in let ce_scope = T.Env.add T.default_scope_var c ce in (* pun scope var with c *) @@ -2565,6 +2552,19 @@ and infer_obj env s dec_fields at : T.typ = end; t +and validate_parenthetical env = function + | None -> () + | Some par -> + let attrs = infer_exp env par in + let [@warning "-8"] T.Object, attrs_flds = T.as_obj attrs in + let unrecognised = List.(filter (fun {T.lab; _} -> lab <> "cycles") attrs_flds |> map (fun {T.lab; _} -> lab)) in + if unrecognised <> [] then warn env par.at "M0200" "unrecognised attribute %s in parenthetical note" (List.hd unrecognised); + let cyc = List.(filter (fun {T.lab; _} -> lab = "cycles") attrs_flds) in + if cyc <> [] && not T.(sub (List.hd cyc).typ nat) then + local_error env par.at "M0201" + "expected Nat type for attribute cycles, but it has type%a" + display_typ_expand (List.hd cyc).T.typ + and check_system_fields env sort scope tfs dec_fields = List.iter (fun df -> match sort, df.it.vis.it, df.it.dec.it with diff --git a/test/fail/cycle-type.mo b/test/fail/cycle-type.mo index ae2e9e9288f..5bdf54b8047 100644 --- a/test/fail/cycle-type.mo +++ b/test/fail/cycle-type.mo @@ -1,5 +1,6 @@ actor { func _bad(a : actor { foo : () -> async () }) : async () { - await (with cycles = 'C') a.foo() + await (with cycles = 'C') a.foo(); + await (with cycles = "Can't") async (); } } diff --git a/test/fail/ok/cycle-type.tc.ok b/test/fail/ok/cycle-type.tc.ok index 2d901aca1f6..599ad7e11b3 100644 --- a/test/fail/ok/cycle-type.tc.ok +++ b/test/fail/ok/cycle-type.tc.ok @@ -1,2 +1,4 @@ cycle-type.mo:3.31-3.38: type error [M0201], expected Nat type for attribute cycles, but it has type Char +cycle-type.mo:4.35-4.43: type error [M0201], expected Nat type for attribute cycles, but it has type + Text From b9b3c176fdf8b16b779485bb990452f8594feaac Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Wed, 23 Oct 2024 13:33:54 +0200 Subject: [PATCH 081/127] accept --- test/run-drun/ok/par.tc.ok | 1 + 1 file changed, 1 insertion(+) create mode 100644 test/run-drun/ok/par.tc.ok diff --git a/test/run-drun/ok/par.tc.ok b/test/run-drun/ok/par.tc.ok new file mode 100644 index 00000000000..ab1c3ae8183 --- /dev/null +++ b/test/run-drun/ok/par.tc.ok @@ -0,0 +1 @@ +par.mo:48.9-48.67: warning [M0200], unrecognised attribute timeout in parenthetical note From fbaf8b4403fcaf4c1b8da57d1f2c0128742aaf20 Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Wed, 23 Oct 2024 13:42:37 +0200 Subject: [PATCH 082/127] exercise `M0200` too --- test/fail/cycle-type.mo | 5 +++-- test/fail/ok/cycle-type.tc.ok | 6 ++++-- 2 files changed, 7 insertions(+), 4 deletions(-) diff --git a/test/fail/cycle-type.mo b/test/fail/cycle-type.mo index 5bdf54b8047..10ad6fc0f61 100644 --- a/test/fail/cycle-type.mo +++ b/test/fail/cycle-type.mo @@ -1,6 +1,7 @@ actor { func _bad(a : actor { foo : () -> async () }) : async () { - await (with cycles = 'C') a.foo(); - await (with cycles = "Can't") async (); + let defaults = { moot = 9 }; + await (defaults with cycles = 'C') a.foo(); + await (defaults with cycles = "Can't") async (); } } diff --git a/test/fail/ok/cycle-type.tc.ok b/test/fail/ok/cycle-type.tc.ok index 599ad7e11b3..3835db1f923 100644 --- a/test/fail/ok/cycle-type.tc.ok +++ b/test/fail/ok/cycle-type.tc.ok @@ -1,4 +1,6 @@ -cycle-type.mo:3.31-3.38: type error [M0201], expected Nat type for attribute cycles, but it has type +cycle-type.mo:4.40-4.47: warning [M0200], unrecognised attribute moot in parenthetical note +cycle-type.mo:4.40-4.47: type error [M0201], expected Nat type for attribute cycles, but it has type Char -cycle-type.mo:4.35-4.43: type error [M0201], expected Nat type for attribute cycles, but it has type +cycle-type.mo:5.44-5.52: warning [M0200], unrecognised attribute moot in parenthetical note +cycle-type.mo:5.44-5.52: type error [M0201], expected Nat type for attribute cycles, but it has type Text From 599fe2ddcaf9124a158b629b5b6568e7f9a3a02e Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Thu, 24 Oct 2024 13:06:36 +0200 Subject: [PATCH 083/127] WIP: fire&forget doesn't work yet --- test/run-drun/ok/par.drun-run.ok | 3 +++ test/run-drun/ok/par.tc.ok | 2 +- test/run-drun/par.mo | 7 +++++++ 3 files changed, 11 insertions(+), 1 deletion(-) diff --git a/test/run-drun/ok/par.drun-run.ok b/test/run-drun/ok/par.drun-run.ok index 3bbc00e091b..382783eec13 100644 --- a/test/run-drun/ok/par.drun-run.ok +++ b/test/run-drun/ok/par.drun-run.ok @@ -4,3 +4,6 @@ debug.print: test() ingress Completed: Reply: 0x4449444c0000 debug.print: test2() ingress Completed: Reply: 0x4449444c0000 +debug.print: oneshot: 0 +debug.print: oneshot: 0 +ingress Completed: Reply: 0x4449444c0000 diff --git a/test/run-drun/ok/par.tc.ok b/test/run-drun/ok/par.tc.ok index ab1c3ae8183..79dcdcf89b4 100644 --- a/test/run-drun/ok/par.tc.ok +++ b/test/run-drun/ok/par.tc.ok @@ -1 +1 @@ -par.mo:48.9-48.67: warning [M0200], unrecognised attribute timeout in parenthetical note +par.mo:49.9-49.67: warning [M0200], unrecognised attribute timeout in parenthetical note diff --git a/test/run-drun/par.mo b/test/run-drun/par.mo index f3596ea982e..003e9db28a5 100644 --- a/test/run-drun/par.mo +++ b/test/run-drun/par.mo @@ -12,6 +12,7 @@ actor { }; public func oneshot() { + debugPrint ("oneshot: " # debug_show(Cycles.available())); }; public func test() : async () { @@ -54,6 +55,11 @@ actor { debugPrint "test2()"; await (with cycles = 1042) async { assert Cycles.available() == 1042 }; await (with cycles = 3042) (with cycles = 4042) async { assert Cycles.available() == 3042/*FIXME: WHY?*/ }; + }; + + public func test3() : async () { + oneshot(); + (with cycles = 3456) oneshot(); } } @@ -64,3 +70,4 @@ actor { //CALL ingress test "DIDL\x00\x00" //CALL ingress test2 "DIDL\x00\x00" +//CALL ingress test3 "DIDL\x00\x00" From 30dbe01c808a6aa4ba253ed998cb3c78645e8aea Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Thu, 14 Nov 2024 11:59:26 -0300 Subject: [PATCH 084/127] apply parenthetical to one-shot sends --- src/codegen/compile_classical.ml | 18 ++++++++++-------- test/run-drun/ok/par.drun-run.ok | 2 +- 2 files changed, 11 insertions(+), 9 deletions(-) diff --git a/src/codegen/compile_classical.ml b/src/codegen/compile_classical.ml index 0a94d2bf6f5..90ab7e87611 100644 --- a/src/codegen/compile_classical.ml +++ b/src/codegen/compile_classical.ml @@ -10923,22 +10923,22 @@ and compile_prim_invocation (env : E.t) ae p es at = code1 ^^ Type.(match as_obj par.note.Note.typ with - | Object, [] -> compile_unboxed_zero (* a dummy closure *) - | _ -> compile_exp_vanilla env ae par) ^^ (* parenthetical *) + | 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) | _, Type.Local -> - let (set_clos, get_clos) = new_local env "clos" in + let set_clos, get_clos = new_local env "clos" in 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 ^^ 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 *) + | (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 @@ -10949,8 +10949,10 @@ and compile_prim_invocation (env : E.t) ae p es at = let (set_meth_pair, get_meth_pair) = new_local env "meth_pair" in let (set_arg, get_arg) = new_local env "arg" in let _, _, _, ts, _ = Type.as_func e1.note.Note.typ in - let add_cycles = Internals.add_cycles env ae in - + let add_cycles = Type.(match as_obj par.note.Note.typ with + | Object, [] -> Internals.add_cycles env ae (* legacy *) + | _ -> compile_exp_vanilla env ae par ^^ Object.load_idx env par.note.Note.typ "cycles" ^^ Cycles.add env) (* parenthetical *) + in StackRep.of_arity return_arity, code1 ^^ StackRep.adjust env fun_sr SR.Vanilla ^^ set_meth_pair ^^ diff --git a/test/run-drun/ok/par.drun-run.ok b/test/run-drun/ok/par.drun-run.ok index 382783eec13..ef99a540a77 100644 --- a/test/run-drun/ok/par.drun-run.ok +++ b/test/run-drun/ok/par.drun-run.ok @@ -5,5 +5,5 @@ ingress Completed: Reply: 0x4449444c0000 debug.print: test2() ingress Completed: Reply: 0x4449444c0000 debug.print: oneshot: 0 -debug.print: oneshot: 0 +debug.print: oneshot: 3_456 ingress Completed: Reply: 0x4449444c0000 From 5be4240f36c530219cc735e89dba634596d81dda Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Thu, 14 Nov 2024 15:16:30 -0300 Subject: [PATCH 085/127] start with tests for `call_raw` --- test/run-drun/ok/par.drun-run.ok | 4 ++++ test/run-drun/ok/par.tc.ok | 2 +- test/run-drun/par.mo | 17 +++++++++++++++-- 3 files changed, 20 insertions(+), 3 deletions(-) diff --git a/test/run-drun/ok/par.drun-run.ok b/test/run-drun/ok/par.drun-run.ok index ef99a540a77..df18c9fefc6 100644 --- a/test/run-drun/ok/par.drun-run.ok +++ b/test/run-drun/ok/par.drun-run.ok @@ -4,6 +4,10 @@ debug.print: test() ingress Completed: Reply: 0x4449444c0000 debug.print: test2() ingress Completed: Reply: 0x4449444c0000 +debug.print: test3() debug.print: oneshot: 0 debug.print: oneshot: 3_456 ingress Completed: Reply: 0x4449444c0000 +debug.print: test4() +debug.print: rawable: 0 +ingress Completed: Reply: 0x4449444c0000 diff --git a/test/run-drun/ok/par.tc.ok b/test/run-drun/ok/par.tc.ok index 79dcdcf89b4..3b3c1bb2cd2 100644 --- a/test/run-drun/ok/par.tc.ok +++ b/test/run-drun/ok/par.tc.ok @@ -1 +1 @@ -par.mo:49.9-49.67: warning [M0200], unrecognised attribute timeout in parenthetical note +par.mo:53.9-53.67: warning [M0200], unrecognised attribute timeout in parenthetical note diff --git a/test/run-drun/par.mo b/test/run-drun/par.mo index 003e9db28a5..cf0f181df75 100644 --- a/test/run-drun/par.mo +++ b/test/run-drun/par.mo @@ -1,7 +1,7 @@ -import { debugPrint } "mo:⛔"; +import { call_raw; debugPrint; principalOfActor } = "mo:⛔"; import Cycles = "cycles/cycles"; -actor { +actor A { func foo(next : () -> async ()) : async () { await (with cycles = 3000) next() @@ -15,6 +15,10 @@ actor { debugPrint ("oneshot: " # debug_show(Cycles.available())); }; + public func rawable() : async () { + debugPrint ("rawable: " # debug_show(Cycles.available())); + }; + public func test() : async () { debugPrint "test()"; let message = "Hi!"; @@ -58,8 +62,16 @@ actor { }; public func test3() : async () { + debugPrint "test3()"; oneshot(); (with cycles = 3456) oneshot(); + }; + + public func test4() : async () { + debugPrint "test4()"; + ignore await call_raw(principalOfActor A, "rawable", "DIDL\00\00"); + //Cycles.add(34567); + //(with cycles = 3456) oneshot(); } } @@ -71,3 +83,4 @@ actor { //CALL ingress test "DIDL\x00\x00" //CALL ingress test2 "DIDL\x00\x00" //CALL ingress test3 "DIDL\x00\x00" +//CALL ingress test4 "DIDL\x00\x00" From a5b0984f4a7350735e6df07b28d7fa2e6aedcb69 Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Thu, 14 Nov 2024 21:14:35 -0300 Subject: [PATCH 086/127] tweaks --- src/codegen/compile_classical.ml | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/src/codegen/compile_classical.ml b/src/codegen/compile_classical.ml index 90ab7e87611..0144c06d308 100644 --- a/src/codegen/compile_classical.ml +++ b/src/codegen/compile_classical.ml @@ -12130,11 +12130,11 @@ and compile_prim_invocation (env : E.t) ae p es at = (* TBR: Can we do better than using the notes? *) let _, _, _, ts1, _ = Type.as_func f.note.Note.typ in let _, _, _, ts2, _ = Type.as_func k.note.Note.typ in - 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 (set_c, get_c) = new_local env "c" in + 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 set_c, get_c = new_local env "c" 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 @@ -12145,6 +12145,7 @@ and compile_prim_invocation (env : E.t) ae p es at = compile_exp_vanilla env ae c ^^ set_c ^^ FuncDec.ic_call env ts1 ts2 get_meth_pair get_arg get_k get_r get_c add_cycles end + | ICCallRawPrim, [p;m;a;k;r;c] -> SR.unit, begin let set_meth_pair, get_meth_pair = new_local env "meth_pair" in From 137ab9a52c8be41330058a4acaa4bc66a34a1447 Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Fri, 15 Nov 2024 11:35:01 -0300 Subject: [PATCH 087/127] WIP: fix problem with `Cycles.add` not sticking --- src/codegen/compile_classical.ml | 2 +- src/prelude/internals.mo | 2 +- test/run-drun/ok/par.drun-run.ok | 1 + test/run-drun/par.mo | 4 ++-- 4 files changed, 5 insertions(+), 4 deletions(-) diff --git a/src/codegen/compile_classical.ml b/src/codegen/compile_classical.ml index 0144c06d308..06e681b512f 100644 --- a/src/codegen/compile_classical.ml +++ b/src/codegen/compile_classical.ml @@ -5510,7 +5510,7 @@ module IC = struct | Flags.(ICMode | RefMode) -> system_call env "call_cycles_add128" | _ -> - E.trap_with env "cannot accept cycles when running locally" + E.trap_with env "cannot add cycles when running locally" let cycles_accept env = match E.mode env with diff --git a/src/prelude/internals.mo b/src/prelude/internals.mo index 0f6a65f1148..b3785f4f769 100644 --- a/src/prelude/internals.mo +++ b/src/prelude/internals.mo @@ -12,8 +12,8 @@ type @Iter = {next : () -> ?T_}; // Function called by backend to add funds to call. // DO NOT RENAME without modifying compilation. func @pass_cycles(par : ?{ cycles : Nat }) { - @reset_cycles(); let ?{ cycles } = par else return; + @reset_cycles(); if (cycles != 0) { (prim "cyclesAdd" : Nat -> ()) cycles; } diff --git a/test/run-drun/ok/par.drun-run.ok b/test/run-drun/ok/par.drun-run.ok index df18c9fefc6..abdd16f542b 100644 --- a/test/run-drun/ok/par.drun-run.ok +++ b/test/run-drun/ok/par.drun-run.ok @@ -10,4 +10,5 @@ debug.print: oneshot: 3_456 ingress Completed: Reply: 0x4449444c0000 debug.print: test4() debug.print: rawable: 0 +debug.print: rawable: 34_567 ingress Completed: Reply: 0x4449444c0000 diff --git a/test/run-drun/par.mo b/test/run-drun/par.mo index cf0f181df75..6338980062b 100644 --- a/test/run-drun/par.mo +++ b/test/run-drun/par.mo @@ -70,8 +70,8 @@ actor A { public func test4() : async () { debugPrint "test4()"; ignore await call_raw(principalOfActor A, "rawable", "DIDL\00\00"); - //Cycles.add(34567); - //(with cycles = 3456) oneshot(); + Cycles.add(34567); + ignore await /*(with cycles = 3456)*/ call_raw(principalOfActor A, "rawable", "DIDL\00\00"); } } From 2b27bf9be341d674063d8a067e60235ec4520cc4 Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Fri, 29 Nov 2024 11:11:48 +0100 Subject: [PATCH 088/127] eliminate a warning --- src/mo_frontend/printers.ml | 1 + 1 file changed, 1 insertion(+) diff --git a/src/mo_frontend/printers.ml b/src/mo_frontend/printers.ml index 7105e3e7cc7..f3f9ef04d94 100644 --- a/src/mo_frontend/printers.ml +++ b/src/mo_frontend/printers.ml @@ -167,6 +167,7 @@ let string_of_symbol = function | X (N N_exp_plain) -> "" | X (N N_exp_post_bl_) -> "" | X (N N_exp_post_ob_) -> "" + | X (N N_option_exp_post_ob__) -> "?" | X (N N_exp_un_bl_) -> "" | X (N N_exp_un_ob_) -> "" | X (N N_func_body) -> "" From 92976f893b759d54f6fe4bc8586981a5209de136 Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Fri, 29 Nov 2024 11:50:34 +0100 Subject: [PATCH 089/127] remove warnings --- src/ir_passes/async.ml | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/src/ir_passes/async.ml b/src/ir_passes/async.ml index 503e43030d4..d7c22391780 100644 --- a/src/ir_passes/async.ml +++ b/src/ir_passes/async.ml @@ -335,9 +335,8 @@ let transform prog = let (nary_async, nary_reply, reject, clean), def = new_nary_async_reply ts2 in - let (Object, pars_fs) = T.(as_obj pars.note.typ) in - let hasCycles = Type.(sub pars.note.typ (Obj(Object, [{ lab = "cycles"; typ = nat; src = empty_src}]))) in - assert (pars_fs = [] || hasCycles); (* FIXME: remove *) + let (Object, pars_fs) = T.(as_obj pars.note.Note.typ) in + let hasCycles = Type.(sub pars.note.Note.typ (Obj(Object, [{ lab = "cycles"; typ = nat; src = empty_src}]))) in let setup = if hasCycles then Some (thenE From 336de0beb8d7ec80e046b9419f2dd789418dec13 Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Fri, 29 Nov 2024 11:55:05 +0100 Subject: [PATCH 090/127] simplify --- src/ir_passes/async.ml | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) diff --git a/src/ir_passes/async.ml b/src/ir_passes/async.ml index d7c22391780..e1b62cdfe95 100644 --- a/src/ir_passes/async.ml +++ b/src/ir_passes/async.ml @@ -332,10 +332,7 @@ let transform prog = in let exp1' = t_exp exp1 in let exp2' = t_exp exp2 in - let (nary_async, nary_reply, reject, clean), def = - new_nary_async_reply ts2 - in - let (Object, pars_fs) = T.(as_obj pars.note.Note.typ) in + let (nary_async, nary_reply, reject, clean), def = new_nary_async_reply ts2 in let hasCycles = Type.(sub pars.note.Note.typ (Obj(Object, [{ lab = "cycles"; typ = nat; src = empty_src}]))) in let setup = if hasCycles @@ -343,7 +340,6 @@ let transform prog = (natE Mo_values.Numerics.Nat.zero |> assignVarE "@cycles") (primE SystemCyclesAddPrim [dotE pars "cycles" T.nat])) else None in - (blockE ( letP (tupP [varP nary_async; varP nary_reply; varP reject; varP clean]) def :: From 8a7c490cb6d357dd86a6563576d42350980cf84c Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Fri, 29 Nov 2024 15:34:21 +0100 Subject: [PATCH 091/127] WIP: try to warn on non-send calls --- src/mo_def/arrange.ml | 1 + src/mo_frontend/typing.ml | 22 ++++++++++++++++++---- test/fail/cycle-type.mo | 12 +++++++----- 3 files changed, 26 insertions(+), 9 deletions(-) diff --git a/src/mo_def/arrange.ml b/src/mo_def/arrange.ml index 7b413636dbe..3d9e36d3478 100644 --- a/src/mo_def/arrange.ml +++ b/src/mo_def/arrange.ml @@ -114,6 +114,7 @@ module Make (Cfg : Config) = struct | AsyncE (None, Type.Fut, tb, e) -> "AsyncE" $$ [typ_bind tb; exp e] | AsyncE (Some par, Type.Fut, tb, e) -> "AsyncE()" $$ [exp par; typ_bind tb; exp e] | AsyncE (None, Type.Cmp, tb, e) -> "AsyncE*" $$ [typ_bind tb; exp e] + | AsyncE (Some _ , Type.Cmp, tb, e) -> assert false; | AwaitE (Type.Fut, e) -> "AwaitE" $$ [exp e] | AwaitE (Type.Cmp, e) -> "AwaitE*" $$ [exp e] | AssertE (Runtime, e) -> "AssertE" $$ [exp e] diff --git a/src/mo_frontend/typing.ml b/src/mo_frontend/typing.ml index e519edd72bc..a52d034fd49 100644 --- a/src/mo_frontend/typing.ml +++ b/src/mo_frontend/typing.ml @@ -151,6 +151,7 @@ let recover f y = recover_with () f y let display_lab = Lib.Format.display T.pp_lab let display_typ = Lib.Format.display T.pp_typ +let display_typ_list = Lib.Format.display (Format.pp_print_list T.pp_typ) let display_typ_expand = Lib.Format.display T.pp_typ_expand @@ -1586,8 +1587,9 @@ and infer_exp'' env exp : T.typ = let ts1 = match pat.it with TupP _ -> T.seq_of_tup t1 | _ -> [t1] in T.Func (sort, c, T.close_binds cs tbs, List.map (T.close cs) ts1, List.map (T.close cs) ts2) | CallE (par_opt, exp1, inst, exp2) -> - if not env.pre then validate_parenthetical env par_opt; - infer_call env exp1 inst exp2 exp.at None + let t = infer_call env exp1 inst exp2 exp.at None in + if not env.pre then validate_parenthetical env (Some exp1.note.note_typ) par_opt; + t | BlockE decs -> let t, _ = infer_block env decs exp.at false in t @@ -1718,7 +1720,7 @@ and infer_exp'' env exp : T.typ = | AsyncE (par_opt, s, typ_bind, exp1) -> error_in Flags.[WASIMode; WasmMode] env exp1.at "M0086" "async expressions are not supported"; - if not env.pre then validate_parenthetical env par_opt; (* TODO: in restricted environment? *) + if not env.pre then validate_parenthetical env None par_opt; (* TODO: in restricted environment? *) let t1, next_cap = check_AsyncCap env "async expression" exp.at in let c, tb, ce, cs = check_typ_bind env typ_bind in let ce_scope = T.Env.add T.default_scope_var c ce in (* pun scope var with c *) @@ -2552,9 +2554,21 @@ and infer_obj env s dec_fields at : T.typ = end; t -and validate_parenthetical env = function +and validate_parenthetical env typ_opt = function | None -> () | Some par -> + begin match typ_opt with + | Some fun_ty when T.is_func fun_ty -> + let s, _, _, _, ts2 = T.as_func fun_ty in + local_error env par.at "M02041" + "result has types %a" display_typ_list ts2; + begin match ts2 with + | _ when T.is_shared_sort s -> (); + | [cod] when T.is_async cod -> (); + | _ -> assert false; warn env par.at "M0202" "unexpected parenthetical note on a non-send call"; + end + | _ -> () + end; let attrs = infer_exp env par in let [@warning "-8"] T.Object, attrs_flds = T.as_obj attrs in let unrecognised = List.(filter (fun {T.lab; _} -> lab <> "cycles") attrs_flds |> map (fun {T.lab; _} -> lab)) in diff --git a/test/fail/cycle-type.mo b/test/fail/cycle-type.mo index 10ad6fc0f61..41ef56f026d 100644 --- a/test/fail/cycle-type.mo +++ b/test/fail/cycle-type.mo @@ -1,7 +1,9 @@ actor { - func _bad(a : actor { foo : () -> async () }) : async () { - let defaults = { moot = 9 }; - await (defaults with cycles = 'C') a.foo(); - await (defaults with cycles = "Can't") async (); - } + func _bad(a : actor { foo : () -> async () }) : async () { + let defaults = { moot = 9 }; + await (defaults with cycles = 'C') a.foo(); + await (defaults with cycles = "Can't") async (); + func nonSend() : async Nat = async 42; + ignore await (defaults with cycles = 0) nonSend(); + } } From 05eb14526228b8ad2cdd13cde23bdeeb3248f91b Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Fri, 29 Nov 2024 15:48:40 +0100 Subject: [PATCH 092/127] fix M0202 --- src/lang_utils/error_codes.ml | 1 + src/mo_frontend/typing.ml | 8 +++----- test/fail/cycle-type.mo | 4 ++-- test/fail/ok/cycle-type.tc.ok | 9 +++++---- 4 files changed, 11 insertions(+), 11 deletions(-) diff --git a/src/lang_utils/error_codes.ml b/src/lang_utils/error_codes.ml index f356a27c3bb..d3fd7e62cd9 100644 --- a/src/lang_utils/error_codes.ml +++ b/src/lang_utils/error_codes.ml @@ -205,4 +205,5 @@ let error_codes : (string * string option) list = "M0199", Some([%blob "lang_utils/error_codes/M0199.md"]); (* Deprecate experimental stable memory *) "M0200", Some([%blob "lang_utils/error_codes/M0200.md"]); (* Unrecognised attribute in parenthetical note *) "M0201", None; (* `cycle` attribute in parenthetical note must be of type `Nat` *) + "M0202", None; (* parenthetical note must be applied to a message send *) ] diff --git a/src/mo_frontend/typing.ml b/src/mo_frontend/typing.ml index a52d034fd49..32aba11b390 100644 --- a/src/mo_frontend/typing.ml +++ b/src/mo_frontend/typing.ml @@ -1981,14 +1981,14 @@ and check_exp' env0 t exp : T.typ = in check_exp_strong (adjoin_vals env' ve2) t2 exp; t - | CallE (_FIXME, exp1, inst, exp2), _ -> - ignore (Option.map (infer_exp env) _FIXME); + | CallE (par_opt, exp1, inst, exp2), _ -> let t' = infer_call env exp1 inst exp2 exp.at (Some t) in if not (T.sub t' t) then local_error env0 exp.at "M0096" "expression of type%a\ncannot produce expected type%a" display_typ_expand t' display_typ_expand t; + if not env.pre then validate_parenthetical env (Some exp1.note.note_typ) par_opt; t' | TagE (id, exp1), T.Variant fs when List.exists (fun T.{lab; _} -> lab = id.it) fs -> let {T.typ; _} = List.find (fun T.{lab; typ;_} -> lab = id.it) fs in @@ -2560,12 +2560,10 @@ and validate_parenthetical env typ_opt = function begin match typ_opt with | Some fun_ty when T.is_func fun_ty -> let s, _, _, _, ts2 = T.as_func fun_ty in - local_error env par.at "M02041" - "result has types %a" display_typ_list ts2; begin match ts2 with | _ when T.is_shared_sort s -> (); | [cod] when T.is_async cod -> (); - | _ -> assert false; warn env par.at "M0202" "unexpected parenthetical note on a non-send call"; + | _ -> warn env par.at "M0202" "unexpected parenthetical note on a non-send call"; end | _ -> () end; diff --git a/test/fail/cycle-type.mo b/test/fail/cycle-type.mo index 41ef56f026d..bef05b9d86a 100644 --- a/test/fail/cycle-type.mo +++ b/test/fail/cycle-type.mo @@ -3,7 +3,7 @@ actor { let defaults = { moot = 9 }; await (defaults with cycles = 'C') a.foo(); await (defaults with cycles = "Can't") async (); - func nonSend() : async Nat = async 42; - ignore await (defaults with cycles = 0) nonSend(); + func nonSend() : Nat = 42; + ignore (with) nonSend(); } } diff --git a/test/fail/ok/cycle-type.tc.ok b/test/fail/ok/cycle-type.tc.ok index 3835db1f923..a926c8b1504 100644 --- a/test/fail/ok/cycle-type.tc.ok +++ b/test/fail/ok/cycle-type.tc.ok @@ -1,6 +1,7 @@ -cycle-type.mo:4.40-4.47: warning [M0200], unrecognised attribute moot in parenthetical note -cycle-type.mo:4.40-4.47: type error [M0201], expected Nat type for attribute cycles, but it has type +cycle-type.mo:4.44-4.51: warning [M0200], unrecognised attribute moot in parenthetical note +cycle-type.mo:4.44-4.51: type error [M0201], expected Nat type for attribute cycles, but it has type Char -cycle-type.mo:5.44-5.52: warning [M0200], unrecognised attribute moot in parenthetical note -cycle-type.mo:5.44-5.52: type error [M0201], expected Nat type for attribute cycles, but it has type +cycle-type.mo:5.48-5.56: warning [M0200], unrecognised attribute moot in parenthetical note +cycle-type.mo:5.48-5.56: type error [M0201], expected Nat type for attribute cycles, but it has type Text +cycle-type.mo:7.23-7.32: warning [M0202], unexpected parenthetical note on a non-send call From 0a9f6c097302ac5ecb55ab7d345f05aaddb8dcb1 Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Fri, 29 Nov 2024 17:36:39 +0100 Subject: [PATCH 093/127] fix warnings --- src/ir_def/construct.ml | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/src/ir_def/construct.ml b/src/ir_def/construct.ml index b46207ab118..9fe7c32b20e 100644 --- a/src/ir_def/construct.ml +++ b/src/ir_def/construct.ml @@ -92,12 +92,11 @@ let primE prim es = | ICReplyPrim _ | ICRejectPrim -> T.Non | ICCallerPrim -> T.caller - | ICStableWrite _ -> T.unit - | ICStableRead t -> t - | ICMethodNamePrim -> T.text - | ICPerformGC | ICStableWrite _ + | ICPerformGC | SystemCyclesAddPrim -> T.unit + | ICStableRead t -> t + | ICMethodNamePrim -> T.text | ICStableSize _ -> T.nat64 | IdxPrim | DerefArrayOffset -> T.(as_immut (as_array_sub (List.hd es).note.Note.typ)) @@ -170,7 +169,7 @@ let nullE () = } let cps_asyncE s typ1 par typ2 e = - { it = PrimE (CPSAsync (s, typ1, if s = Fut then par else nullE ()), [e]); + { it = PrimE (CPSAsync (s, typ1, if s = T.Fut then par else nullE ()), [e]); at = no_region; note = Note.{ def with typ = T.Async (s, typ1, typ2); eff = eff e } } From fb97b74ab3121d637af19648fc19f35ac837801b Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Sat, 30 Nov 2024 17:18:51 +0100 Subject: [PATCH 094/127] warn empty notes --- src/lang_utils/error_codes.ml | 1 + src/mo_frontend/typing.ml | 2 +- test/fail/cycle-type.mo | 4 +++- test/fail/ok/cycle-type.tc.ok | 2 ++ 4 files changed, 7 insertions(+), 2 deletions(-) diff --git a/src/lang_utils/error_codes.ml b/src/lang_utils/error_codes.ml index d3fd7e62cd9..82387709734 100644 --- a/src/lang_utils/error_codes.ml +++ b/src/lang_utils/error_codes.ml @@ -206,4 +206,5 @@ let error_codes : (string * string option) list = "M0200", Some([%blob "lang_utils/error_codes/M0200.md"]); (* Unrecognised attribute in parenthetical note *) "M0201", None; (* `cycle` attribute in parenthetical note must be of type `Nat` *) "M0202", None; (* parenthetical note must be applied to a message send *) + "M0203", None; (* parenthetical note has no attributes *) ] diff --git a/src/mo_frontend/typing.ml b/src/mo_frontend/typing.ml index 32aba11b390..897e70d021a 100644 --- a/src/mo_frontend/typing.ml +++ b/src/mo_frontend/typing.ml @@ -151,7 +151,6 @@ let recover f y = recover_with () f y let display_lab = Lib.Format.display T.pp_lab let display_typ = Lib.Format.display T.pp_typ -let display_typ_list = Lib.Format.display (Format.pp_print_list T.pp_typ) let display_typ_expand = Lib.Format.display T.pp_typ_expand @@ -2569,6 +2568,7 @@ and validate_parenthetical env typ_opt = function end; let attrs = infer_exp env par in let [@warning "-8"] T.Object, attrs_flds = T.as_obj attrs in + if attrs_flds = [] then warn env par.at "M0203" "redundant empty parenthetical note"; let unrecognised = List.(filter (fun {T.lab; _} -> lab <> "cycles") attrs_flds |> map (fun {T.lab; _} -> lab)) in if unrecognised <> [] then warn env par.at "M0200" "unrecognised attribute %s in parenthetical note" (List.hd unrecognised); let cyc = List.(filter (fun {T.lab; _} -> lab = "cycles") attrs_flds) in diff --git a/test/fail/cycle-type.mo b/test/fail/cycle-type.mo index bef05b9d86a..547cfa22e01 100644 --- a/test/fail/cycle-type.mo +++ b/test/fail/cycle-type.mo @@ -1,9 +1,11 @@ actor { - func _bad(a : actor { foo : () -> async () }) : async () { + func _bad(a : actor { foo : () -> async (); oneway : () -> () }) : async () { let defaults = { moot = 9 }; await (defaults with cycles = 'C') a.foo(); await (defaults with cycles = "Can't") async (); func nonSend() : Nat = 42; ignore (with) nonSend(); + (with cycles = 999) a.oneway(); // should not warn + ({} with) a.oneway(); } } diff --git a/test/fail/ok/cycle-type.tc.ok b/test/fail/ok/cycle-type.tc.ok index a926c8b1504..680e9d05290 100644 --- a/test/fail/ok/cycle-type.tc.ok +++ b/test/fail/ok/cycle-type.tc.ok @@ -5,3 +5,5 @@ cycle-type.mo:5.48-5.56: warning [M0200], unrecognised attribute moot in parenth cycle-type.mo:5.48-5.56: type error [M0201], expected Nat type for attribute cycles, but it has type Text cycle-type.mo:7.23-7.32: warning [M0202], unexpected parenthetical note on a non-send call +cycle-type.mo:7.23-7.32: warning [M0203], redundant empty parenthetical note +cycle-type.mo:9.19-9.29: warning [M0203], redundant empty parenthetical note From fe6107ebec3f3717b8ebe7d1257ea4c429a55348 Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Sat, 30 Nov 2024 17:38:22 +0100 Subject: [PATCH 095/127] tweaks --- src/mo_frontend/typing.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/mo_frontend/typing.ml b/src/mo_frontend/typing.ml index 897e70d021a..ac9173ac43e 100644 --- a/src/mo_frontend/typing.ml +++ b/src/mo_frontend/typing.ml @@ -2560,9 +2560,9 @@ and validate_parenthetical env typ_opt = function | Some fun_ty when T.is_func fun_ty -> let s, _, _, _, ts2 = T.as_func fun_ty in begin match ts2 with - | _ when T.is_shared_sort s -> (); - | [cod] when T.is_async cod -> (); - | _ -> warn env par.at "M0202" "unexpected parenthetical note on a non-send call"; + | _ when T.is_shared_sort s -> () + | [cod] when T.is_async cod -> () + | _ -> warn env par.at "M0202" "unexpected parenthetical note on a non-send call" end | _ -> () end; From 277789ad9580e7793c38b421ad925c88ff5a9e1b Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Mon, 2 Dec 2024 10:27:10 +0100 Subject: [PATCH 096/127] what did I think here? --- src/ir_passes/await.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/ir_passes/await.ml b/src/ir_passes/await.ml index ca5a06b53b6..c14bfefe199 100644 --- a/src/ir_passes/await.ml +++ b/src/ir_passes/await.ml @@ -100,7 +100,7 @@ let rec t_async context exp = (LabelEnv.singleton Throw (Cont k_fail))) in cps_asyncE s typ1 (match par_opt with - | Some par -> assert false; optE par + | Some par -> assert false(*FIXME:; optE par*) | None -> primE ICCyclesPrim []) (typ exp1) (forall [tb] ([k_ret; k_fail; k_clean] -->* (c_exp context' exp1 (ContVar k_ret)))) From 2a2b19a17a87654fec41c62e3416f20aae252ea9 Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Mon, 2 Dec 2024 12:51:36 +0100 Subject: [PATCH 097/127] Apply suggestions from code review --- src/ir_passes/async.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/ir_passes/async.ml b/src/ir_passes/async.ml index e1b62cdfe95..ac1a71826d9 100644 --- a/src/ir_passes/async.ml +++ b/src/ir_passes/async.ml @@ -24,7 +24,7 @@ module ConRenaming = E.Make(struct type t = con let compare = Cons.compare end) (* Helpers *) -let selfcallE (cyc : exp) ts e1 e2 e3 e4 = +let selfcallE cyc ts e1 e2 e3 e4 = { it = SelfCallE (cyc, ts, e1, e2, e3, e4); at = no_region; note = Note.{ def with typ = unit } } @@ -161,7 +161,7 @@ let let_seq ts e d_of_vs = | ts -> let xs = fresh_vars "x" ts in let p = tupVarsP xs in - (letP p e) :: d_of_vs xs + letP p e :: d_of_vs xs (* name e in f unless named already *) let ensureNamed e f = From 85075eb12045997d2b927ca194cd5c2aa19fb05b Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Mon, 2 Dec 2024 13:35:13 +0100 Subject: [PATCH 098/127] don't arrange trivial parentheticals --- src/ir_def/arrange_ir.ml | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/src/ir_def/arrange_ir.ml b/src/ir_def/arrange_ir.ml index 6d5e3829eaf..93051c3e4a0 100644 --- a/src/ir_def/arrange_ir.ml +++ b/src/ir_def/arrange_ir.ml @@ -60,7 +60,8 @@ and args = function and arg a = Atom a.it and prim = function - | CallPrim (ts, _FIXME) -> "CallPrim" $$ List.map typ ts @ [exp _FIXME] + | CallPrim (ts, par) when empty par -> "CallPrim" $$ List.map typ ts + | CallPrim (ts, par) -> "CallPrim()" $$ List.map typ ts @ [exp par] | 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] @@ -122,6 +123,11 @@ and prim = function | ICStableWrite t -> "ICStableWrite" $$ [typ t] | ICStableRead t -> "ICStableRead" $$ [typ t] +and empty exp = + Type.(is_obj exp.note.Note.typ + && (let (s, fls) = as_obj exp.note.Note.typ in + s = Object && fls = [])) + and mut = function | Const -> Atom "Const" | Var -> Atom "Var" From 1982b484c93f80331b7dfc03ac159f40f88415ae Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Mon, 2 Dec 2024 13:55:37 +0100 Subject: [PATCH 099/127] put the parenthetical in front --- src/ir_def/arrange_ir.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/ir_def/arrange_ir.ml b/src/ir_def/arrange_ir.ml index 93051c3e4a0..bef458bb027 100644 --- a/src/ir_def/arrange_ir.ml +++ b/src/ir_def/arrange_ir.ml @@ -109,7 +109,7 @@ and prim = function | OtherPrim s -> Atom s | CPSAwait (Type.Fut, t) -> "CPSAwait" $$ [typ t] | CPSAwait (Type.Cmp, t) -> "CPSAwait*" $$ [typ t] - | CPSAsync (Type.Fut, t, par) -> "CPSAsync" $$ [typ t] @ [exp par] + | CPSAsync (Type.Fut, t, par) -> "CPSAsync" $$ [exp par] @ [typ t] | CPSAsync (Type.Cmp, t, _) -> "CPSAsync*" $$ [typ t] | ICArgDataPrim -> Atom "ICArgDataPrim" | ICStableSize t -> "ICStableSize" $$ [typ t] From a93b8e1f7d27c73b763384be557274926e70217c Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Mon, 2 Dec 2024 13:56:19 +0100 Subject: [PATCH 100/127] Update src/ir_def/arrange_ir.ml --- src/ir_def/arrange_ir.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/ir_def/arrange_ir.ml b/src/ir_def/arrange_ir.ml index bef458bb027..1463cf8ac3d 100644 --- a/src/ir_def/arrange_ir.ml +++ b/src/ir_def/arrange_ir.ml @@ -61,7 +61,7 @@ and arg a = Atom a.it and prim = function | CallPrim (ts, par) when empty par -> "CallPrim" $$ List.map typ ts - | CallPrim (ts, par) -> "CallPrim()" $$ List.map typ ts @ [exp par] + | CallPrim (ts, par) -> "CallPrim()" $$ [exp par] @ List.map typ ts | 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] From f0f9436c1997269f3545998a873abe61a2368b95 Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Tue, 3 Dec 2024 11:57:43 +0100 Subject: [PATCH 101/127] test both old and new style --- test/run-drun/actor-class-cycles.mo | 13 +++++++++---- 1 file changed, 9 insertions(+), 4 deletions(-) diff --git a/test/run-drun/actor-class-cycles.mo b/test/run-drun/actor-class-cycles.mo index cd9048aaf8a..76d608df88d 100644 --- a/test/run-drun/actor-class-cycles.mo +++ b/test/run-drun/actor-class-cycles.mo @@ -19,12 +19,17 @@ actor a { Prim.debugPrint(debug_show({ iteration = i })); Prim.debugPrint(debug_show({ balance = round(Cycles.balance()) })); let c = await { - //Cycles.add((i + 1) * 10_000_000_000_000); FIXME: this should still work without a parenthetical - (with cycles = (i + 1) * 10_000_000_000_000) - Lib.C(); + if (i == 1) { + // test old-style + Cycles.add((i + 1) * 10_000_000_000_000); + Lib.C(); + } else { + (with cycles = (i + 1) * 10_000_000_000_000) + Lib.C(); + } }; let {current = cur; initial = init} = await c.balance(); - Prim.debugPrint(debug_show({ current = round(cur); initial = init } )); + Prim.debugPrint(debug_show({ current = round(cur); initial = init })); } } }; From 21ce382d8433783714bc2f03fbfadfc86b2ab104 Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Tue, 3 Dec 2024 13:18:52 +0100 Subject: [PATCH 102/127] accept --- test/fail/ok/syntax5.tc.ok | 1 + 1 file changed, 1 insertion(+) diff --git a/test/fail/ok/syntax5.tc.ok b/test/fail/ok/syntax5.tc.ok index a882586ced3..fdc4dc1c398 100644 --- a/test/fail/ok/syntax5.tc.ok +++ b/test/fail/ok/syntax5.tc.ok @@ -18,3 +18,4 @@ syntax5.mo:3.1: syntax error [M0001], unexpected end of input, expected one of t [ ] + with seplist(,) ) From fff0acabce7e505b301135c29faf568d74368bb0 Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Tue, 3 Dec 2024 14:01:20 +0100 Subject: [PATCH 103/127] disable `drun-eop-*` for now --- default.nix | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/default.nix b/default.nix index d1b13ca8e4f..21d9ac6b21a 100644 --- a/default.nix +++ b/default.nix @@ -512,8 +512,8 @@ rec { drun-compacting-gc = snty_compacting_gc_subdir "run-drun" [ moc nixpkgs.drun ] ; drun-generational-gc = snty_generational_gc_subdir "run-drun" [ moc nixpkgs.drun ] ; drun-incremental-gc = snty_incremental_gc_subdir "run-drun" [ moc nixpkgs.drun ] ; - drun-eop-release = enhanced_orthogonal_persistence_subdir "run-drun" [ moc nixpkgs.drun ] ; - drun-eop-debug = snty_enhanced_orthogonal_persistence_subdir "run-drun" [ moc nixpkgs.drun ] ; + ## FOR NOW drun-eop-release = enhanced_orthogonal_persistence_subdir "run-drun" [ moc nixpkgs.drun ] ; + ## FOR NOW drun-eop-debug = snty_enhanced_orthogonal_persistence_subdir "run-drun" [ moc nixpkgs.drun ] ; fail = test_subdir "fail" [ moc ]; fail-eop = enhanced_orthogonal_persistence_subdir "fail" [ moc ]; repl = test_subdir "repl" [ moc ]; From df56dcc5650096e8d10c30863a8d93a6bdd343c5 Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Tue, 3 Dec 2024 15:27:19 +0100 Subject: [PATCH 104/127] tidy up --- test/run-drun/test-cycles-state.mo | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/test/run-drun/test-cycles-state.mo b/test/run-drun/test-cycles-state.mo index 8518b42ec62..31a440e3e4f 100644 --- a/test/run-drun/test-cycles-state.mo +++ b/test/run-drun/test-cycles-state.mo @@ -35,15 +35,13 @@ actor a { assert (cs == 1000_000); assert (Cycles.refunded() == 1000_000); }; - do { - // check cycles reset to zero on send + do { // check cycles reset to zero on send let cs = await wallet.available(); assert (cs == 0); assert (Cycles.refunded() == 0); }; - do { - // check cycles additive to zero on send + do { // check cycles additive to zero on send Cycles.add(1000_000); Cycles.add(2000_000); let cs = await wallet.available(); From b7aab764ff2fe9ac6394710305ec3367ce17aacb Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Tue, 3 Dec 2024 15:34:38 +0100 Subject: [PATCH 105/127] be more explicit with `AsyncE()` --- src/ir_def/arrange_ir.ml | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/ir_def/arrange_ir.ml b/src/ir_def/arrange_ir.ml index 1463cf8ac3d..629af8a549f 100644 --- a/src/ir_def/arrange_ir.ml +++ b/src/ir_def/arrange_ir.ml @@ -22,8 +22,9 @@ 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 (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] + | AsyncE (None, Type.Fut, tb, e, t) -> "AsyncE" $$ [typ_bind tb; exp e; typ t] + | AsyncE (Some par, Type.Fut, tb, e, t) -> "AsyncE()" $$ [exp par; 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) -> From 4ba0df17641d41d03467819af632202d56150b2f Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Tue, 3 Dec 2024 16:08:05 +0100 Subject: [PATCH 106/127] simplify --- src/ir_passes/async.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/ir_passes/async.ml b/src/ir_passes/async.ml index ac1a71826d9..593bfc8eb96 100644 --- a/src/ir_passes/async.ml +++ b/src/ir_passes/async.ml @@ -407,11 +407,11 @@ let transform prog = [tb], [Func(_, _, [], ts1, []) as contT; _; _], []) -> - (t_typ (T.seq (List.map (T.open_ [t0]) ts1)),t_typ (T.open_ [t0] contT)) + t_typ (T.seq (List.map (T.open_ [t0]) ts1)),t_typ (T.open_ [t0] contT) | t -> assert false in let k = let v = fresh_var "v" t1 in - v --> (ic_replyE ret_tys (varE v)) in + v --> ic_replyE ret_tys (varE v) in let r = let e = fresh_var "e" catch in e --> ic_rejectE (errorMessageE (varE e)) in @@ -437,7 +437,7 @@ let transform prog = [tb], [Func(_, _, [], ts1, []) as contT; _; _], []) -> - (t_typ (T.seq (List.map (T.open_ [t0]) ts1)),t_typ (T.open_ [t0] contT)) + t_typ (T.seq (List.map (T.open_ [t0]) ts1)),t_typ (T.open_ [t0] contT) | _ -> assert false in let k = let v = fresh_var "v" t1 in From 83841508e86bef1005a0106cc5e31789b37509ab Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Tue, 3 Dec 2024 16:16:17 +0100 Subject: [PATCH 107/127] function-body `CPSAsync(Fut)` should ignore the cycle send note on it --- src/ir_passes/async.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/ir_passes/async.ml b/src/ir_passes/async.ml index 593bfc8eb96..42bd9565c7a 100644 --- a/src/ir_passes/async.ml +++ b/src/ir_passes/async.ml @@ -400,7 +400,7 @@ let transform prog = let args' = t_args args in let typbinds' = t_typ_binds typbinds in let t0, cps = match exp.it with - | PrimE (CPSAsync (Fut, t0, _FIXME), [cps]) -> t_typ t0, cps + | PrimE (CPSAsync (Fut, t0, {it = PrimE (ICCyclesPrim, []); _}), [cps]) -> t_typ t0, cps | _ -> assert false in let t1, contT = match typ cps with | Func (_, _, @@ -430,7 +430,7 @@ let transform prog = let args' = t_args args in let typbinds' = t_typ_binds typbinds in let t0, cps = match exp.it with - | PrimE (CPSAsync (Fut, t0, _FIXME), [cps]) -> t_typ t0, cps (* TBR *) + | PrimE (CPSAsync (Fut, t0, {it = PrimE (ICCyclesPrim, []); _}), [cps]) -> t_typ t0, cps (* TBR *) | _ -> assert false in let t1, contT = match typ cps with | Func (_, _, From 360974a0038a0ef31d9eba49b457bedbd490e551 Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Tue, 3 Dec 2024 17:59:29 +0100 Subject: [PATCH 108/127] tweaks --- src/codegen/compile_classical.ml | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/codegen/compile_classical.ml b/src/codegen/compile_classical.ml index 854302ba4d8..52db0690f44 100644 --- a/src/codegen/compile_classical.ml +++ b/src/codegen/compile_classical.ml @@ -12395,10 +12395,10 @@ and compile_exp_with_hint (env : E.t) ae sr_hint exp = FuncDec.lit env ae x sort control captured args mk_body return_tys exp.at | 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 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 = match cyc.it with From 309a2316c4692cacff50228e46b7ba2c726c9fbd Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Tue, 3 Dec 2024 18:00:37 +0100 Subject: [PATCH 109/127] fix `cps_asyncE` for the `AsyncE` (freestanding) case --- src/ir_passes/await.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/ir_passes/await.ml b/src/ir_passes/await.ml index c14bfefe199..091f3ebf552 100644 --- a/src/ir_passes/await.ml +++ b/src/ir_passes/await.ml @@ -455,8 +455,8 @@ and c_exp' context exp k = cps_asyncE T.Fut typ1 (match par_opt with | Some par when T.(sub (typ par) (Obj (Object, [{ lab = "cycles"; typ = nat; src = empty_src}]))) -> optE par - | None -> primE ICCyclesPrim [] - | Some _ -> nullE ()) (typ exp1) + (*| Some _ -> FIXME: pass 0 cycles: optE (recE [cycles = 0])*) + | _ -> nullE ()) (typ exp1) (forall [tb] ([k_ret; k_fail; k_clean] -->* (c_exp context' exp1 (ContVar k_ret)))) in let k' = meta (typ cps_async) From 64696a12944ffddbff1147a7227182451618102c Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Tue, 3 Dec 2024 21:04:42 +0100 Subject: [PATCH 110/127] explicitly zero `cycles` when user doesn't specify any --- src/ir_passes/await.ml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/ir_passes/await.ml b/src/ir_passes/await.ml index 091f3ebf552..f59293bb771 100644 --- a/src/ir_passes/await.ml +++ b/src/ir_passes/await.ml @@ -455,7 +455,8 @@ and c_exp' context exp k = cps_asyncE T.Fut typ1 (match par_opt with | Some par when T.(sub (typ par) (Obj (Object, [{ lab = "cycles"; typ = nat; src = empty_src}]))) -> optE par - (*| Some _ -> FIXME: pass 0 cycles: optE (recE [cycles = 0])*) + | Some _ + -> optE (recordE ["cycles", natE Mo_values.Numerics.Nat.zero]) | _ -> nullE ()) (typ exp1) (forall [tb] ([k_ret; k_fail; k_clean] -->* (c_exp context' exp1 (ContVar k_ret)))) in From a0d475a7f04922c274d1348777551ec40eaee85e Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Fri, 6 Dec 2024 13:18:03 +0100 Subject: [PATCH 111/127] add new API --- src/codegen/compile_classical.ml | 1 + 1 file changed, 1 insertion(+) diff --git a/src/codegen/compile_classical.ml b/src/codegen/compile_classical.ml index f2fd9507f70..cd3f35cbe15 100644 --- a/src/codegen/compile_classical.ml +++ b/src/codegen/compile_classical.ml @@ -5066,6 +5066,7 @@ module IC = struct E.add_func_import env "ic0" "accept_message" [] []; E.add_func_import env "ic0" "call_data_append" (i32s 2) []; E.add_func_import env "ic0" "call_cycles_add128" (i64s 2) []; + E.add_func_import env "ic0" "call_with_best_effort_response" [I32Type] []; E.add_func_import env "ic0" "call_new" (i32s 8) []; E.add_func_import env "ic0" "call_perform" [] [I32Type]; E.add_func_import env "ic0" "call_on_cleanup" (i32s 2) []; From c9bd84f1d2cad0786371729c3db67da66655fc30 Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Fri, 6 Dec 2024 19:22:00 +0100 Subject: [PATCH 112/127] WIP: prepare for `timeout` --- src/lang_utils/error_codes.ml | 1 + src/mo_frontend/typing.ml | 9 +++++++-- test/run-drun/ok/par.tc.ok | 2 +- 3 files changed, 9 insertions(+), 3 deletions(-) diff --git a/src/lang_utils/error_codes.ml b/src/lang_utils/error_codes.ml index 8175af188d4..8d087f9f1ee 100644 --- a/src/lang_utils/error_codes.ml +++ b/src/lang_utils/error_codes.ml @@ -208,4 +208,5 @@ let error_codes : (string * string option) list = "M0202", None; (* parenthetical note must be applied to a message send *) "M0203", None; (* parenthetical note has no attributes *) "M0204", Some([%blob "lang_utils/error_codes/M0204.md"]); (* Unrecognised attribute in parenthetical note *) + "M0205", None; (* `timeout` attribute in parenthetical note must be of type `Nat32` *) ] diff --git a/src/mo_frontend/typing.ml b/src/mo_frontend/typing.ml index 1e2c8e1fd0c..f23dc4351af 100644 --- a/src/mo_frontend/typing.ml +++ b/src/mo_frontend/typing.ml @@ -2567,13 +2567,18 @@ and validate_parenthetical env typ_opt = function let attrs = infer_exp env par in let [@warning "-8"] T.Object, attrs_flds = T.as_obj attrs in if attrs_flds = [] then warn env par.at "M0203" "redundant empty parenthetical note"; - let unrecognised = List.(filter (fun {T.lab; _} -> lab <> "cycles") attrs_flds |> map (fun {T.lab; _} -> lab)) in + let unrecognised = List.(filter (fun {T.lab; _} -> lab <> "cycles" && lab <> "timeout") attrs_flds |> map (fun {T.lab; _} -> lab)) in if unrecognised <> [] then warn env par.at "M0204" "unrecognised attribute %s in parenthetical note" (List.hd unrecognised); let cyc = List.(filter (fun {T.lab; _} -> lab = "cycles") attrs_flds) in if cyc <> [] && not T.(sub (List.hd cyc).typ nat) then local_error env par.at "M0201" "expected Nat type for attribute cycles, but it has type%a" - display_typ_expand (List.hd cyc).T.typ + display_typ_expand (List.hd cyc).T.typ; + let timeout = List.(filter (fun {T.lab; _} -> lab = "timeout") attrs_flds) in + if timeout <> [] && not T.(sub (List.hd timeout).typ nat) then + local_error env par.at "M0205" + "expected Nat32 type for attribute timeout, but it has type%a" + display_typ_expand (List.hd timeout).T.typ and check_system_fields env sort scope tfs dec_fields = List.iter (fun df -> diff --git a/test/run-drun/ok/par.tc.ok b/test/run-drun/ok/par.tc.ok index 217c4db1e9c..de9ebdaae49 100644 --- a/test/run-drun/ok/par.tc.ok +++ b/test/run-drun/ok/par.tc.ok @@ -1 +1 @@ -par.mo:53.9-53.67: warning [M0204], unrecognised attribute timeout in parenthetical note +par.mo:53.9-53.67: warning [M0204], unrecognised attribute yeah in parenthetical note From 3bed728d61e55bbc664db5aed0c584c7c45e0c97 Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Fri, 6 Dec 2024 20:09:11 +0100 Subject: [PATCH 113/127] WIP: `replyDeadline` is still 0 --- test/run-drun/ok/par.tc.ok | 2 +- test/run-drun/par.mo | 3 ++- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/test/run-drun/ok/par.tc.ok b/test/run-drun/ok/par.tc.ok index de9ebdaae49..545a7f3affa 100644 --- a/test/run-drun/ok/par.tc.ok +++ b/test/run-drun/ok/par.tc.ok @@ -1 +1 @@ -par.mo:53.9-53.67: warning [M0204], unrecognised attribute yeah in parenthetical note +par.mo:54.9-54.67: warning [M0204], unrecognised attribute yeah in parenthetical note diff --git a/test/run-drun/par.mo b/test/run-drun/par.mo index 6338980062b..03adce4104d 100644 --- a/test/run-drun/par.mo +++ b/test/run-drun/par.mo @@ -1,9 +1,10 @@ -import { call_raw; debugPrint; principalOfActor } = "mo:⛔"; +import { call_raw; debugPrint; principalOfActor; replyDeadline } = "mo:⛔"; import Cycles = "cycles/cycles"; actor A { func foo(next : () -> async ()) : async () { + assert 0 : Nat64 == replyDeadline(); await (with cycles = 3000) next() }; From cbfacdf6da5bd5ad8188588fac1cb4068aedfce1 Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Fri, 6 Dec 2024 20:30:37 +0100 Subject: [PATCH 114/127] check for `timeout` type error --- test/fail/cycle-type.mo | 1 + test/fail/ok/cycle-type.tc.ok | 2 ++ 2 files changed, 3 insertions(+) diff --git a/test/fail/cycle-type.mo b/test/fail/cycle-type.mo index 547cfa22e01..5010bbd91c3 100644 --- a/test/fail/cycle-type.mo +++ b/test/fail/cycle-type.mo @@ -7,5 +7,6 @@ actor { ignore (with) nonSend(); (with cycles = 999) a.oneway(); // should not warn ({} with) a.oneway(); + await (with timeout = 'T') a.foo(); } } diff --git a/test/fail/ok/cycle-type.tc.ok b/test/fail/ok/cycle-type.tc.ok index fbea128105b..4a9e2b6b863 100644 --- a/test/fail/ok/cycle-type.tc.ok +++ b/test/fail/ok/cycle-type.tc.ok @@ -7,3 +7,5 @@ cycle-type.mo:5.48-5.56: type error [M0201], expected Nat type for attribute cyc cycle-type.mo:7.23-7.32: warning [M0202], unexpected parenthetical note on a non-send call cycle-type.mo:7.23-7.32: warning [M0203], redundant empty parenthetical note cycle-type.mo:9.19-9.29: warning [M0203], redundant empty parenthetical note +cycle-type.mo:10.36-10.43: type error [M0205], expected Nat32 type for attribute timeout, but it has type + Char From f1cc9074cf45e489e3ef1396b473ea80d5f0362e Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Fri, 6 Dec 2024 21:13:43 +0100 Subject: [PATCH 115/127] intro `nat32` --- src/mo_types/type.ml | 1 + src/mo_types/type.mli | 1 + 2 files changed, 2 insertions(+) diff --git a/src/mo_types/type.ml b/src/mo_types/type.ml index 98ec59d1ed5..fd723f54a91 100644 --- a/src/mo_types/type.ml +++ b/src/mo_types/type.ml @@ -312,6 +312,7 @@ let compare_field f1 f2 = let unit = Tup [] let bool = Prim Bool let nat = Prim Nat +let nat32 = Prim Nat32 let nat64 = Prim Nat64 let int = Prim Int let text = Prim Text diff --git a/src/mo_types/type.mli b/src/mo_types/type.mli index d7d179a9a7f..6bfcb279e5d 100644 --- a/src/mo_types/type.mli +++ b/src/mo_types/type.mli @@ -89,6 +89,7 @@ val is_shared_sort : 'a shared -> bool val unit : typ val bool : typ val nat : typ +val nat32 : typ val nat64 : typ val int : typ val text : typ From 2edbcd93933e34aa19e221054dc2624f1c8362d8 Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Sat, 7 Dec 2024 00:30:21 +0100 Subject: [PATCH 116/127] WIP: begin checking `timeout` --- src/ir_passes/await.ml | 3 ++- src/mo_frontend/typing.ml | 2 +- test/run-drun/ok/par.drun-run.ok | 2 ++ test/run-drun/par.mo | 10 +++++++++- 4 files changed, 14 insertions(+), 3 deletions(-) diff --git a/src/ir_passes/await.ml b/src/ir_passes/await.ml index f59293bb771..3ddf3864c65 100644 --- a/src/ir_passes/await.ml +++ b/src/ir_passes/await.ml @@ -452,8 +452,9 @@ and c_exp' context exp k = | _ -> assert false in let cps_async = + let has par lab ty = T.(sub (typ par) (Obj (Object, [{ lab; typ = ty; src = empty_src}]))) in cps_asyncE T.Fut typ1 (match par_opt with - | Some par when T.(sub (typ par) (Obj (Object, [{ lab = "cycles"; typ = nat; src = empty_src}]))) + | Some par when has par "cycles" T.nat || has par "timeout" T.nat32 -> optE par | Some _ -> optE (recordE ["cycles", natE Mo_values.Numerics.Nat.zero]) diff --git a/src/mo_frontend/typing.ml b/src/mo_frontend/typing.ml index f23dc4351af..01ba2bd08b4 100644 --- a/src/mo_frontend/typing.ml +++ b/src/mo_frontend/typing.ml @@ -2575,7 +2575,7 @@ and validate_parenthetical env typ_opt = function "expected Nat type for attribute cycles, but it has type%a" display_typ_expand (List.hd cyc).T.typ; let timeout = List.(filter (fun {T.lab; _} -> lab = "timeout") attrs_flds) in - if timeout <> [] && not T.(sub (List.hd timeout).typ nat) then + if timeout <> [] && not T.(sub (List.hd timeout).typ nat32) then local_error env par.at "M0205" "expected Nat32 type for attribute timeout, but it has type%a" display_typ_expand (List.hd timeout).T.typ diff --git a/test/run-drun/ok/par.drun-run.ok b/test/run-drun/ok/par.drun-run.ok index abdd16f542b..67c149ebc93 100644 --- a/test/run-drun/ok/par.drun-run.ok +++ b/test/run-drun/ok/par.drun-run.ok @@ -12,3 +12,5 @@ debug.print: test4() debug.print: rawable: 0 debug.print: rawable: 34_567 ingress Completed: Reply: 0x4449444c0000 +debug.print: test5() +ingress Completed: Reply: 0x4449444c0000 diff --git a/test/run-drun/par.mo b/test/run-drun/par.mo index 03adce4104d..452c1ecd7c6 100644 --- a/test/run-drun/par.mo +++ b/test/run-drun/par.mo @@ -50,7 +50,7 @@ actor A { assert 3 == (await (with cycles = 101) closA()); assert 3 == (await (with cycles = 102) closB()); - await (with yeah = 8; timeout = 55; cycles = 1000) + await (with yeah = 8; timeout = 55 : Nat32/* FIXME: checking mode */; cycles = 1000) foo(func() : async () = async { assert message == "Hi!" }); await (with cycles = 5000) bar(func() : async () = async { assert message == "Hi!" }); @@ -73,6 +73,13 @@ actor A { ignore await call_raw(principalOfActor A, "rawable", "DIDL\00\00"); Cycles.add(34567); ignore await /*(with cycles = 3456)*/ call_raw(principalOfActor A, "rawable", "DIDL\00\00"); + }; + + public func test5() : async () { + await (with timeout = 3 : Nat32/* FIXME: checking mode */) async { + assert 0 : Nat64 == replyDeadline(); + debugPrint "test5()"; + } } } @@ -85,3 +92,4 @@ actor A { //CALL ingress test2 "DIDL\x00\x00" //CALL ingress test3 "DIDL\x00\x00" //CALL ingress test4 "DIDL\x00\x00" +//CALL ingress test5 "DIDL\x00\x00" From 83e70abe1769e9d4ffd17995508fe14bfa9e1e49 Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Sat, 7 Dec 2024 14:22:04 +0100 Subject: [PATCH 117/127] WIP: invoke `call_with_best_effort_response` --- src/codegen/compile_classical.ml | 15 ++++++++++----- src/ir_passes/async.ml | 8 ++++---- 2 files changed, 14 insertions(+), 9 deletions(-) diff --git a/src/codegen/compile_classical.ml b/src/codegen/compile_classical.ml index cd3f35cbe15..e2b7c825900 100644 --- a/src/codegen/compile_classical.ml +++ b/src/codegen/compile_classical.ml @@ -12405,7 +12405,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 (cyc, ts, exp_f, exp_k, exp_r, exp_c) -> + | SelfCallE (par, 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 @@ -12413,11 +12413,16 @@ and compile_exp_with_hint (env : E.t) ae sr_hint exp = 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 = match cyc.it with + let add_cycles = match par.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) + | _ when Type.(sub par.note.Note.typ (Opt (Obj (Object, [{ lab = "cycles"; typ = nat; src = empty_src}])))) -> + Internals.pass_cycles env ae (compile_exp_vanilla env ae par) | _ -> Internals.pass_cycles env ae (Opt.null_lit env) in + let add_timeout = match par.it with + | _ when Type.(sub par.note.Note.typ (Opt (Obj (Object, [{ lab = "timeout"; typ = nat; src = empty_src}])))) -> + compile_unboxed_const 3l ^^ + IC.system_call env "call_with_best_effort_response" + | _ -> G.nop in FuncDec.async_body env ae ts captured mk_body exp.at ^^ Tagged.load_forwarding_pointer env ^^ set_future ^^ @@ -12433,7 +12438,7 @@ and compile_exp_with_hint (env : E.t) ae sr_hint exp = get_k get_r get_c - add_cycles + (add_cycles ^^ add_timeout) | ActorE (ds, fs, _, _) -> fatal "Local actors not supported by backend" | NewObjE (Type.(Object | Module | Memory) as _sort, fs, _) -> diff --git a/src/ir_passes/async.ml b/src/ir_passes/async.ml index 42bd9565c7a..c1a189e7d20 100644 --- a/src/ir_passes/async.ml +++ b/src/ir_passes/async.ml @@ -24,8 +24,8 @@ module ConRenaming = E.Make(struct type t = con let compare = Cons.compare end) (* Helpers *) -let selfcallE cyc ts e1 e2 e3 e4 = - { it = SelfCallE (cyc, ts, e1, e2, e3, e4); +let selfcallE par ts e1 e2 e3 e4 = + { it = SelfCallE (par, ts, e1, e2, e3, e4); at = no_region; note = Note.{ def with typ = unit } } @@ -287,7 +287,7 @@ let transform prog = (t_exp a -*- t_exp krb).it | _ -> assert false end - | PrimE (CPSAsync (Fut, t, cyc), [exp1]) -> + | PrimE (CPSAsync (Fut, t, par), [exp1]) -> let t0 = t_typ t in let tb, ts1 = match typ exp1 with | Func(_,_, [tb], [Func(_, _, [], ts1, []); _; _], []) -> @@ -306,7 +306,7 @@ let transform prog = e --> ic_rejectE (errorMessageE (varE e)) in let ic_cleanup = varE (var "@cleanup" clean_contT) in let exp' = callE (t_exp exp1) [t0] (tupE [ic_reply; ic_reject; ic_cleanup]) in - expD (selfcallE cyc ts1 exp' (varE nary_reply) (varE reject) (varE clean)) + expD (selfcallE par ts1 exp' (varE nary_reply) (varE reject) (varE clean)) ] (varE nary_async) ).it From 0878d9066ab8a1d102313b5f987cef16077368ba Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Sat, 7 Dec 2024 15:09:22 +0100 Subject: [PATCH 118/127] access at the correct type and observe the deadline --- src/codegen/compile_classical.ml | 11 +++++++---- test/run-drun/par.mo | 2 +- 2 files changed, 8 insertions(+), 5 deletions(-) diff --git a/src/codegen/compile_classical.ml b/src/codegen/compile_classical.ml index e2b7c825900..d61184bb004 100644 --- a/src/codegen/compile_classical.ml +++ b/src/codegen/compile_classical.ml @@ -12416,11 +12416,14 @@ and compile_exp_with_hint (env : E.t) ae sr_hint exp = let add_cycles = match par.it with | LitE NullLit -> Internals.add_cycles env ae (* legacy *) | _ when Type.(sub par.note.Note.typ (Opt (Obj (Object, [{ lab = "cycles"; typ = nat; src = empty_src}])))) -> - Internals.pass_cycles env ae (compile_exp_vanilla env ae par) + Internals.pass_cycles env ae (compile_exp_vanilla env ae par (*FIXME: effects?!*)) | _ -> Internals.pass_cycles env ae (Opt.null_lit env) in - let add_timeout = match par.it with - | _ when Type.(sub par.note.Note.typ (Opt (Obj (Object, [{ lab = "timeout"; typ = nat; src = empty_src}])))) -> - compile_unboxed_const 3l ^^ + let add_timeout = match par.note.Note.typ with + | (Type.Opt typ) when Type.(sub typ (Obj (Object, [{ lab = "timeout"; typ = nat32; src = empty_src}]))) -> + compile_exp_vanilla env ae par (*FIXME: effects?!*) ^^ + (* this is a naked option, and no need to check is_some *) + Object.load_idx env typ "timeout" ^^ + BitTagged.untag_i32 __LINE__ env Type.Nat32 ^^ IC.system_call env "call_with_best_effort_response" | _ -> G.nop in FuncDec.async_body env ae ts captured mk_body exp.at ^^ diff --git a/test/run-drun/par.mo b/test/run-drun/par.mo index 452c1ecd7c6..00a888edd7e 100644 --- a/test/run-drun/par.mo +++ b/test/run-drun/par.mo @@ -77,8 +77,8 @@ actor A { public func test5() : async () { await (with timeout = 3 : Nat32/* FIXME: checking mode */) async { - assert 0 : Nat64 == replyDeadline(); debugPrint "test5()"; + assert 0 : Nat64 != replyDeadline(); } } } From ec31258f6a3555e419c6f27d37550ab6b11061eb Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Tue, 10 Dec 2024 06:16:34 +0100 Subject: [PATCH 119/127] break out `infer_check_bases_fields` and use it to check just a few select fields in parentheticals --- src/mo_frontend/typing.ml | 172 +++++++++++++++++++++----------------- test/run-drun/par.mo | 4 +- 2 files changed, 99 insertions(+), 77 deletions(-) diff --git a/src/mo_frontend/typing.ml b/src/mo_frontend/typing.ml index 01ba2bd08b4..cfddb0f4b2b 100644 --- a/src/mo_frontend/typing.ml +++ b/src/mo_frontend/typing.ml @@ -1213,9 +1213,9 @@ and infer_exp_promote env exp : T.typ = display_typ_expand t; t' -and infer_exp' f env exp : T.typ = +and infer_exp_wrapper inf f env exp : T.typ = assert (exp.note.note_typ = T.Pre); - let t = infer_exp'' env exp in + let t = inf env exp in assert (t <> T.Pre); let t' = f t in if not env.pre then begin @@ -1226,6 +1226,8 @@ and infer_exp' f env exp : T.typ = end; t' +and infer_exp' f env exp : T.typ = infer_exp_wrapper infer_exp'' f env exp + and infer_exp'' env exp : T.typ = let context = env.context in let in_actor = env.in_actor in @@ -1388,78 +1390,7 @@ and infer_exp'' env exp : T.typ = end; t | ObjE (exp_bases, exp_fields) -> - let open List in - check_ids env "object" "field" - (map (fun (ef : exp_field) -> ef.it.id) exp_fields); - let fts = map (infer_exp_field env) exp_fields in - let bases = map (fun b -> infer_exp_promote env b, b) exp_bases in - let homonymous_fields ft1 ft2 = T.compare_field ft1 ft2 = 0 in - - (* removing explicit fields from the bases *) - let strip (base_t, base) = - let s, base_fts = - try T.as_obj base_t with Invalid_argument _ -> - error env base.at "M0093" - "expected object type, but expression produces type%a" - display_typ_expand base_t in - (* forbid actors as bases *) - if s = T.Actor then - error env base.at "M0178" - "actors cannot serve as bases in record extensions"; - T.(Obj (Object, filter (fun ft -> not (exists (homonymous_fields ft) fts)) base_fts)) - in - let stripped_bases = map strip bases in - - let ambiguous_fields ft1 ft2 = - homonymous_fields ft1 ft2 && - (* allow equivalent type fields *) - match ft1.T.typ, ft2.T.typ with - (* homonymous type fields are ambiguous when unequal *) - | T.Typ c1, T.Typ c2 -> not (eq env exp.at ft1.T.typ ft2.T.typ) - (* homonymous value fields are always ambiguous *) - | _ -> true - in - - (* field disjointness of stripped bases *) - let rec disjoint = function - | [] | [_] -> () - | (h, h_exp) :: t -> - let avoid ft = - let avoid_fields b b_fts = - if exists (ambiguous_fields ft) b_fts then - begin - let frag_typ, frag_sug = match ft.T.typ with - | T.Typ c -> "type ", "" - | _ -> "", " (consider overwriting)" in - info env h_exp.at "%sfield also present in base, here%s" frag_typ frag_sug; - error env b.at "M0177" - "ambiguous %sfield in base%a" - frag_typ - display_lab ft.T.lab - end in - iter (fun (b_t, b) -> avoid_fields b (T.as_obj b_t |> snd)) t in - iter avoid (T.as_obj h |> snd); - disjoint t in - disjoint (map2 (fun b_t b -> b_t, b) stripped_bases exp_bases); - - (* do not allow var fields for now (to avoid aliasing) *) - begin if not (!Flags.experimental_field_aliasing) then - let immutable_base b_typ b_exp = - let constant_field (ft : T.field) = - if T.(is_mut ft.typ) then - begin - info env b_exp.at "overwrite field to resolve error"; - error env b_exp.at "M0179" - "base has non-aliasable var field%a" - display_lab ft.T.lab - end - in - iter constant_field (T.as_obj b_typ |> snd) - in - iter2 immutable_base stripped_bases exp_bases - end; - let t_base = T.(fold_left glb (Obj (Object, [])) stripped_bases) in - T.(glb t_base (Obj (Object, sort T.compare_field fts))) + infer_check_bases_fields env [] exp.at exp_bases exp_fields | DotE (exp1, id) -> let t1 = infer_exp_promote env exp1 in let s, tfs = @@ -1796,6 +1727,89 @@ and infer_exp_field env rf = let t1 = if mut.it = Syntax.Var then T.Mut t else t in T.{ lab = id.it; typ = t1; src = empty_src } +and infer_check_bases_fields env (check_fields : T.field list) exp_at exp_bases exp_fields = + let open List in + check_ids env "object" "field" + (map (fun (ef : exp_field) -> ef.it.id) exp_fields); + + let infer_or_check rf = + let { mut; id; exp } = rf.it in + match List.find_opt (fun ft -> ft.T.lab = id.it) check_fields with + | Some exp_field -> + check_exp_field env rf [exp_field]; + exp_field + | _ -> infer_exp_field env rf in + + let fts = map infer_or_check exp_fields in + let bases = map (fun b -> infer_exp_promote env b, b) exp_bases in + let homonymous_fields ft1 ft2 = T.compare_field ft1 ft2 = 0 in + + (* removing explicit fields from the bases *) + let strip (base_t, base) = + let s, base_fts = + try T.as_obj base_t with Invalid_argument _ -> + error env base.at "M0093" + "expected object type, but expression produces type%a" + display_typ_expand base_t in + (* forbid actors as bases *) + if s = T.Actor then + error env base.at "M0178" + "actors cannot serve as bases in record extensions"; + T.(Obj (Object, filter (fun ft -> not (exists (homonymous_fields ft) fts)) base_fts)) + in + let stripped_bases = map strip bases in + + let ambiguous_fields ft1 ft2 = + homonymous_fields ft1 ft2 && + (* allow equivalent type fields *) + match ft1.T.typ, ft2.T.typ with + (* homonymous type fields are ambiguous when unequal *) + | T.Typ c1, T.Typ c2 -> not (eq env exp_at ft1.T.typ ft2.T.typ) + (* homonymous value fields are always ambiguous *) + | _ -> true + in + + (* field disjointness of stripped bases *) + let rec disjoint = function + | [] | [_] -> () + | (h, h_exp) :: t -> + let avoid ft = + let avoid_fields b b_fts = + if exists (ambiguous_fields ft) b_fts then + begin + let frag_typ, frag_sug = match ft.T.typ with + | T.Typ c -> "type ", "" + | _ -> "", " (consider overwriting)" in + info env h_exp.at "%sfield also present in base, here%s" frag_typ frag_sug; + error env b.at "M0177" + "ambiguous %sfield in base%a" + frag_typ + display_lab ft.T.lab + end in + iter (fun (b_t, b) -> avoid_fields b (T.as_obj b_t |> snd)) t in + iter avoid (T.as_obj h |> snd); + disjoint t in + disjoint (map2 (fun b_t b -> b_t, b) stripped_bases exp_bases); + + (* do not allow var fields for now (to avoid aliasing) *) + begin if not (!Flags.experimental_field_aliasing) then + let immutable_base b_typ b_exp = + let constant_field (ft : T.field) = + if T.(is_mut ft.typ) then + begin + info env b_exp.at "overwrite field to resolve error"; + error env b_exp.at "M0179" + "base has non-aliasable var field%a" + display_lab ft.T.lab + end + in + iter constant_field (T.as_obj b_typ |> snd) + in + iter2 immutable_base stripped_bases exp_bases + end; + let t_base = T.(fold_left glb (Obj (Object, [])) stripped_bases) in + T.(glb t_base (Obj (Object, sort T.compare_field fts))) + and check_exp_strong env t exp = check_exp {env with weak = false} t exp @@ -2564,7 +2578,15 @@ and validate_parenthetical env typ_opt = function end | _ -> () end; - let attrs = infer_exp env par in + (*let [@warning "-8"] ObjE (bases, fields) = par.it in*) + let [@warning "-8"] par_infer env { it = ObjE (bases, fields); _ } = + let checked = T.[ { lab = "cycles"; typ = nat; src = empty_src} + ; { lab = "timeout"; typ = nat32; src = empty_src} + ] in + infer_check_bases_fields env checked par.at bases fields in + let attrs = infer_exp_wrapper par_infer T.as_immut env par in + (*let attrs = infer_check_bases_fields env checked par.at bases fields in*) + (*let attrs = infer_exp env par in*) let [@warning "-8"] T.Object, attrs_flds = T.as_obj attrs in if attrs_flds = [] then warn env par.at "M0203" "redundant empty parenthetical note"; let unrecognised = List.(filter (fun {T.lab; _} -> lab <> "cycles" && lab <> "timeout") attrs_flds |> map (fun {T.lab; _} -> lab)) in diff --git a/test/run-drun/par.mo b/test/run-drun/par.mo index 00a888edd7e..09d227002e5 100644 --- a/test/run-drun/par.mo +++ b/test/run-drun/par.mo @@ -50,7 +50,7 @@ actor A { assert 3 == (await (with cycles = 101) closA()); assert 3 == (await (with cycles = 102) closB()); - await (with yeah = 8; timeout = 55 : Nat32/* FIXME: checking mode */; cycles = 1000) + await (with yeah = 8; timeout = 55; cycles = 1000) foo(func() : async () = async { assert message == "Hi!" }); await (with cycles = 5000) bar(func() : async () = async { assert message == "Hi!" }); @@ -76,7 +76,7 @@ actor A { }; public func test5() : async () { - await (with timeout = 3 : Nat32/* FIXME: checking mode */) async { + await (with timeout = 3) async { debugPrint "test5()"; assert 0 : Nat64 != replyDeadline(); } From ca663025c1b90eb4f7c7e62bb0f7003feb76b0ba Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Tue, 10 Dec 2024 06:27:34 +0100 Subject: [PATCH 120/127] some errors are now emitted in a centralised fashion --- src/lang_utils/error_codes.ml | 2 -- src/mo_frontend/typing.ml | 7 ++----- test/fail/ok/cycle-type.tc.ok | 14 +++++++++----- 3 files changed, 11 insertions(+), 12 deletions(-) diff --git a/src/lang_utils/error_codes.ml b/src/lang_utils/error_codes.ml index 8d087f9f1ee..331c13da77d 100644 --- a/src/lang_utils/error_codes.ml +++ b/src/lang_utils/error_codes.ml @@ -204,9 +204,7 @@ let error_codes : (string * string option) list = "M0198", Some([%blob "lang_utils/error_codes/M0198.md"]); (* Unused field pattern warning *) "M0199", Some([%blob "lang_utils/error_codes/M0199.md"]); (* Deprecate experimental stable memory *) "M0200", Some([%blob "lang_utils/error_codes/M0200.md"]); (* Cannot determine subtyping or equality *) - "M0201", None; (* `cycle` attribute in parenthetical note must be of type `Nat` *) "M0202", None; (* parenthetical note must be applied to a message send *) "M0203", None; (* parenthetical note has no attributes *) "M0204", Some([%blob "lang_utils/error_codes/M0204.md"]); (* Unrecognised attribute in parenthetical note *) - "M0205", None; (* `timeout` attribute in parenthetical note must be of type `Nat32` *) ] diff --git a/src/mo_frontend/typing.ml b/src/mo_frontend/typing.ml index cfddb0f4b2b..09f38396a8f 100644 --- a/src/mo_frontend/typing.ml +++ b/src/mo_frontend/typing.ml @@ -2578,20 +2578,17 @@ and validate_parenthetical env typ_opt = function end | _ -> () end; - (*let [@warning "-8"] ObjE (bases, fields) = par.it in*) let [@warning "-8"] par_infer env { it = ObjE (bases, fields); _ } = let checked = T.[ { lab = "cycles"; typ = nat; src = empty_src} ; { lab = "timeout"; typ = nat32; src = empty_src} ] in infer_check_bases_fields env checked par.at bases fields in let attrs = infer_exp_wrapper par_infer T.as_immut env par in - (*let attrs = infer_check_bases_fields env checked par.at bases fields in*) - (*let attrs = infer_exp env par in*) let [@warning "-8"] T.Object, attrs_flds = T.as_obj attrs in if attrs_flds = [] then warn env par.at "M0203" "redundant empty parenthetical note"; let unrecognised = List.(filter (fun {T.lab; _} -> lab <> "cycles" && lab <> "timeout") attrs_flds |> map (fun {T.lab; _} -> lab)) in if unrecognised <> [] then warn env par.at "M0204" "unrecognised attribute %s in parenthetical note" (List.hd unrecognised); - let cyc = List.(filter (fun {T.lab; _} -> lab = "cycles") attrs_flds) in + (*let cyc = List.(filter (fun {T.lab; _} -> lab = "cycles") attrs_flds) in if cyc <> [] && not T.(sub (List.hd cyc).typ nat) then local_error env par.at "M0201" "expected Nat type for attribute cycles, but it has type%a" @@ -2600,7 +2597,7 @@ and validate_parenthetical env typ_opt = function if timeout <> [] && not T.(sub (List.hd timeout).typ nat32) then local_error env par.at "M0205" "expected Nat32 type for attribute timeout, but it has type%a" - display_typ_expand (List.hd timeout).T.typ + display_typ_expand (List.hd timeout).T.typ*) and check_system_fields env sort scope tfs dec_fields = List.iter (fun df -> diff --git a/test/fail/ok/cycle-type.tc.ok b/test/fail/ok/cycle-type.tc.ok index 4a9e2b6b863..6870bde2b68 100644 --- a/test/fail/ok/cycle-type.tc.ok +++ b/test/fail/ok/cycle-type.tc.ok @@ -1,11 +1,15 @@ -cycle-type.mo:4.44-4.51: warning [M0204], unrecognised attribute moot in parenthetical note -cycle-type.mo:4.44-4.51: type error [M0201], expected Nat type for attribute cycles, but it has type +cycle-type.mo:4.39-4.42: type error [M0050], literal of type Char -cycle-type.mo:5.48-5.56: warning [M0204], unrecognised attribute moot in parenthetical note -cycle-type.mo:5.48-5.56: type error [M0201], expected Nat type for attribute cycles, but it has type +does not have expected type + Nat +cycle-type.mo:5.39-5.46: type error [M0050], literal of type Text +does not have expected type + Nat cycle-type.mo:7.23-7.32: warning [M0202], unexpected parenthetical note on a non-send call cycle-type.mo:7.23-7.32: warning [M0203], redundant empty parenthetical note cycle-type.mo:9.19-9.29: warning [M0203], redundant empty parenthetical note -cycle-type.mo:10.36-10.43: type error [M0205], expected Nat32 type for attribute timeout, but it has type +cycle-type.mo:10.31-10.34: type error [M0050], literal of type Char +does not have expected type + Nat32 From 4c37385e1a5eb16628dbce7fe8ae902057402009 Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Tue, 10 Dec 2024 06:52:21 +0100 Subject: [PATCH 121/127] tweaks --- src/ir_passes/await.ml | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/src/ir_passes/await.ml b/src/ir_passes/await.ml index 3ddf3864c65..549347fe9a5 100644 --- a/src/ir_passes/await.ml +++ b/src/ir_passes/await.ml @@ -95,9 +95,9 @@ let rec t_async context exp = let k_fail = fresh_err_cont T.unit in let k_clean = fresh_bail_cont T.unit in let context' = - LabelEnv.add Cleanup (Cont k_clean) - (LabelEnv.add Return (Cont k_ret) - (LabelEnv.singleton Throw (Cont k_fail))) + LabelEnv.(add Cleanup (Cont k_clean) + (add Return (Cont k_ret) + (singleton Throw (Cont k_fail)))) in cps_asyncE s typ1 (match par_opt with | Some par -> assert false(*FIXME:; optE par*) @@ -443,9 +443,9 @@ and c_exp' context exp k = let k_fail = fresh_err_cont T.unit in let k_clean = fresh_bail_cont T.unit in let context' = - LabelEnv.add Cleanup (Cont k_clean) - (LabelEnv.add Return (Cont k_ret) - (LabelEnv.singleton Throw (Cont k_fail))) + LabelEnv.(add Cleanup (Cont k_clean) + (add Return (Cont k_ret) + (singleton Throw (Cont k_fail)))) in let r = match LabelEnv.find_opt Throw context with | Some (Cont r) -> r @@ -647,8 +647,8 @@ and t_comp_unit context = function | T.Await -> let throw = fresh_err_cont T.unit in let context' = - LabelEnv.add Cleanup (Cont (var "@cleanup" bail_contT)) - (LabelEnv.add Throw (Cont throw) context) in + LabelEnv.(add Cleanup (Cont (var "@cleanup" bail_contT)) + (add Throw (Cont throw) context)) in let e = fresh_var "e" T.catch in ProgU [ funcD throw e (assertE (falseE ())); @@ -675,8 +675,8 @@ and t_ignore_throw context exp = | _ -> let throw = fresh_err_cont T.unit in let context' = - LabelEnv.add Cleanup (Cont (var "@cleanup" bail_contT)) - (LabelEnv.add Throw (Cont throw) context) in + LabelEnv.(add Cleanup (Cont (var "@cleanup" bail_contT)) + (add Throw (Cont throw) context)) in let e = fresh_var "e" T.catch in { (blockE [ funcD throw e (tupE[]); From e79c48d7b1bd121826dcf37cb8a1e56ad1e8e19d Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Tue, 10 Dec 2024 11:01:32 +0100 Subject: [PATCH 122/127] intro and use `SystemTimeoutPrim` --- src/codegen/compile_classical.ml | 7 +++++-- src/ir_def/arrange_ir.ml | 3 ++- src/ir_def/check_ir.ml | 3 +++ src/ir_def/construct.ml | 5 +++-- src/ir_def/ir.ml | 3 ++- src/ir_passes/async.ml | 11 +++++++++-- test/run-drun/par.mo | 11 +++++++++++ 7 files changed, 35 insertions(+), 8 deletions(-) diff --git a/src/codegen/compile_classical.ml b/src/codegen/compile_classical.ml index d61184bb004..14629b66201 100644 --- a/src/codegen/compile_classical.ml +++ b/src/codegen/compile_classical.ml @@ -12210,6 +12210,8 @@ and compile_prim_invocation (env : E.t) ae p es at = SR.Vanilla, Cycles.available env | SystemCyclesRefundedPrim, [] -> SR.Vanilla, Cycles.refunded env + | SystemCyclesBurnPrim, [e1] -> + SR.Vanilla, compile_exp_vanilla env ae e1 ^^ Cycles.burn env | ICCyclesPrim, [] -> SR.Vanilla, G.i (LocalGet (nr 0l)) ^^ (* closed-over bindings *) @@ -12230,8 +12232,9 @@ and compile_prim_invocation (env : E.t) ae p es at = ] end (Opt.null_lit env) - | SystemCyclesBurnPrim, [e1] -> - SR.Vanilla, compile_exp_vanilla env ae e1 ^^ Cycles.burn env + + | SystemTimeoutPrim, [e1] -> + SR.unit, compile_exp_as env ae (SR.UnboxedWord32 Type.Nat32) e1 ^^ IC.system_call env "call_with_best_effort_response" | SetCertifiedData, [e1] -> SR.unit, compile_exp_vanilla env ae e1 ^^ IC.set_certified_data env diff --git a/src/ir_def/arrange_ir.ml b/src/ir_def/arrange_ir.ml index b3414ae23fc..d008fcd94b6 100644 --- a/src/ir_def/arrange_ir.ml +++ b/src/ir_def/arrange_ir.ml @@ -98,13 +98,14 @@ and prim = function | IcUrlOfBlob -> Atom "IcUrlOfBlob" | SelfRef t -> "SelfRef" $$ [typ t] | SystemTimePrim -> Atom "SystemTimePrim" + | SystemTimeoutPrim -> Atom "SystemTimeoutPrim" | SystemCyclesAddPrim -> Atom "SystemCyclesAddPrim" | SystemCyclesAcceptPrim -> Atom "SystemCyclesAcceptPrim" | SystemCyclesAvailablePrim -> Atom "SystemCyclesAvailablePrim" | SystemCyclesBalancePrim -> Atom "SystemCyclesBalancePrim" | SystemCyclesRefundedPrim -> Atom "SystemCyclesRefundedPrim" - | ICCyclesPrim -> Atom "ICCyclesPrim" | SystemCyclesBurnPrim -> Atom "SystemCyclesBurnPrim" + | ICCyclesPrim -> Atom "ICCyclesPrim" | SetCertifiedData -> Atom "SetCertifiedData" | GetCertificate -> Atom "GetCertificate" | OtherPrim s -> Atom s diff --git a/src/ir_def/check_ir.ml b/src/ir_def/check_ir.ml index 75570b4d42a..463a4d00127 100644 --- a/src/ir_def/check_ir.ml +++ b/src/ir_def/check_ir.ml @@ -690,6 +690,9 @@ let rec check_exp env (exp:Ir.exp) : unit = | SystemCyclesAddPrim, [e1] -> typ e1 <: T.nat; T.unit <: t + | SystemTimeoutPrim, [e1] -> + typ e1 <: T.nat32; + T.unit <: t (* Certified Data *) | SetCertifiedData, [e1] -> typ e1 <: T.blob; diff --git a/src/ir_def/construct.ml b/src/ir_def/construct.ml index 9fe7c32b20e..c673ea61000 100644 --- a/src/ir_def/construct.ml +++ b/src/ir_def/construct.ml @@ -94,6 +94,7 @@ let primE prim es = | ICCallerPrim -> T.caller | ICStableWrite _ | ICPerformGC + | SystemTimeoutPrim | SystemCyclesAddPrim -> T.unit | ICStableRead t -> t | ICMethodNamePrim -> T.text @@ -116,7 +117,7 @@ let primE prim es = | DeserializeOptPrim ts -> T.Opt (T.seq ts) | ICCyclesPrim -> T.(Opt (Obj (Object, [{ lab = "cycles"; typ = nat; src = empty_src}]))) | OtherPrim "trap" -> T.Non - | OtherPrim "call_perform_status" -> T.(Prim Nat32) + | OtherPrim "call_perform_status" -> T.nat32 | OtherPrim "call_perform_message" -> T.text | OtherPrim "array_len" | OtherPrim "blob_size" @@ -268,7 +269,7 @@ let blockE decs exp = let nat32E n = { it = LitE (Nat32Lit n); at = no_region; - note = Note.{ def with typ = T.(Prim Nat32) } + note = Note.{ def with typ = T.nat32 } } let natE n = diff --git a/src/ir_def/ir.ml b/src/ir_def/ir.ml index 2880244697f..4c1217f005e 100644 --- a/src/ir_def/ir.ml +++ b/src/ir_def/ir.ml @@ -159,8 +159,9 @@ and prim = | SystemCyclesAvailablePrim | SystemCyclesBalancePrim | SystemCyclesRefundedPrim - | ICCyclesPrim (* cycles to send by parenthetical *) | SystemCyclesBurnPrim + | ICCyclesPrim (* cycles to send by parenthetical *) + | SystemTimeoutPrim | SetCertifiedData | GetCertificate diff --git a/src/ir_passes/async.ml b/src/ir_passes/async.ml index c1a189e7d20..a676543ad3b 100644 --- a/src/ir_passes/async.ml +++ b/src/ir_passes/async.ml @@ -334,12 +334,19 @@ let transform prog = let exp2' = t_exp exp2 in let (nary_async, nary_reply, reject, clean), def = new_nary_async_reply ts2 in let hasCycles = Type.(sub pars.note.Note.typ (Obj(Object, [{ lab = "cycles"; typ = nat; src = empty_src}]))) in - - let setup = if hasCycles + let hasTimeout = Type.(sub pars.note.Note.typ (Obj(Object, [{ lab = "timeout"; typ = nat32; src = empty_src}]))) in + let cyclesSetup = if hasCycles then Some (thenE (natE Mo_values.Numerics.Nat.zero |> assignVarE "@cycles") (primE SystemCyclesAddPrim [dotE pars "cycles" T.nat])) else None in + let timeoutSetup = if hasTimeout + then Some (primE SystemTimeoutPrim [nat32E Mo_values.Numerics.Nat32.zero]) + else None in + let setup = match cyclesSetup, timeoutSetup with + | Some c, Some t -> Some (thenE c t) + | None, t -> t + | c, _ -> c in (blockE ( letP (tupP [varP nary_async; varP nary_reply; varP reject; varP clean]) def :: diff --git a/test/run-drun/par.mo b/test/run-drun/par.mo index 09d227002e5..217dbc8e74c 100644 --- a/test/run-drun/par.mo +++ b/test/run-drun/par.mo @@ -5,6 +5,7 @@ actor A { func foo(next : () -> async ()) : async () { assert 0 : Nat64 == replyDeadline(); + debugPrint ("foo: " # debug_show(Cycles.available())); await (with cycles = 3000) next() }; @@ -80,6 +81,15 @@ actor A { debugPrint "test5()"; assert 0 : Nat64 != replyDeadline(); } + }; + + public func ext() : async () { + assert 0 : Nat64 != replyDeadline(); + debugPrint ("ext: " # debug_show(Cycles.available())); + }; + + public func test6() : async () { + await (with timeout = 3; cycles = 6543) A.ext() } } @@ -93,3 +103,4 @@ actor A { //CALL ingress test3 "DIDL\x00\x00" //CALL ingress test4 "DIDL\x00\x00" //CALL ingress test5 "DIDL\x00\x00" +//CALL ingress test6 "DIDL\x00\x00" From b5eb704aba11ae7abba0d30eaa6863c20d8f81d7 Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Tue, 10 Dec 2024 11:04:00 +0100 Subject: [PATCH 123/127] accept --- test/run-drun/ok/par.drun-run.ok | 3 +++ test/run-drun/ok/par.tc.ok | 2 +- 2 files changed, 4 insertions(+), 1 deletion(-) diff --git a/test/run-drun/ok/par.drun-run.ok b/test/run-drun/ok/par.drun-run.ok index 67c149ebc93..443fecf80dd 100644 --- a/test/run-drun/ok/par.drun-run.ok +++ b/test/run-drun/ok/par.drun-run.ok @@ -1,6 +1,7 @@ ingress Completed: Reply: 0x4449444c016c01b3c4b1f204680100010a00000000000000000101 ingress Completed: Reply: 0x4449444c0000 debug.print: test() +debug.print: foo: 1_000 ingress Completed: Reply: 0x4449444c0000 debug.print: test2() ingress Completed: Reply: 0x4449444c0000 @@ -14,3 +15,5 @@ debug.print: rawable: 34_567 ingress Completed: Reply: 0x4449444c0000 debug.print: test5() ingress Completed: Reply: 0x4449444c0000 +debug.print: ext: 6_543 +ingress Completed: Reply: 0x4449444c0000 diff --git a/test/run-drun/ok/par.tc.ok b/test/run-drun/ok/par.tc.ok index 545a7f3affa..a4c453f17d3 100644 --- a/test/run-drun/ok/par.tc.ok +++ b/test/run-drun/ok/par.tc.ok @@ -1 +1 @@ -par.mo:54.9-54.67: warning [M0204], unrecognised attribute yeah in parenthetical note +par.mo:55.9-55.67: warning [M0204], unrecognised attribute yeah in parenthetical note From f80ffa8f06fbd9bec014617c5991ddb11cf78b51 Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Tue, 10 Dec 2024 11:11:45 +0100 Subject: [PATCH 124/127] fix warning --- src/ir_def/ir.ml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/ir_def/ir.ml b/src/ir_def/ir.ml index 4c1217f005e..1ec82279629 100644 --- a/src/ir_def/ir.ml +++ b/src/ir_def/ir.ml @@ -312,8 +312,9 @@ let map_prim t_typ t_id t_exp p = | SystemCyclesAvailablePrim | SystemCyclesBalancePrim | SystemCyclesRefundedPrim - | ICCyclesPrim | SystemCyclesBurnPrim + | ICCyclesPrim + | SystemTimeoutPrim | SetCertifiedData | GetCertificate | OtherPrim _ -> p From 2e58517e6beef15ee67016f99289e9443b8909e7 Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Tue, 10 Dec 2024 11:16:49 +0100 Subject: [PATCH 125/127] unfake, but beware of the duplication! --- src/ir_passes/async.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/ir_passes/async.ml b/src/ir_passes/async.ml index a676543ad3b..e3d63a38b77 100644 --- a/src/ir_passes/async.ml +++ b/src/ir_passes/async.ml @@ -341,7 +341,7 @@ let transform prog = (primE SystemCyclesAddPrim [dotE pars "cycles" T.nat])) else None in let timeoutSetup = if hasTimeout - then Some (primE SystemTimeoutPrim [nat32E Mo_values.Numerics.Nat32.zero]) + then Some (primE SystemTimeoutPrim [dotE pars "timeout" T.nat32]) else None in let setup = match cyclesSetup, timeoutSetup with | Some c, Some t -> Some (thenE c t) From 7cb6cf053e6ea62c27017b6214c92ecb90507669 Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Tue, 10 Dec 2024 14:05:15 +0100 Subject: [PATCH 126/127] WIP: `timeout` for one-shot calls this probably doesn't make much sense --- src/codegen/compile_classical.ml | 11 +++++++---- test/run-drun/ok/par.tc.ok | 2 +- test/run-drun/par.mo | 2 ++ 3 files changed, 10 insertions(+), 5 deletions(-) diff --git a/src/codegen/compile_classical.ml b/src/codegen/compile_classical.ml index 14629b66201..3f6308136b8 100644 --- a/src/codegen/compile_classical.ml +++ b/src/codegen/compile_classical.ml @@ -10958,16 +10958,19 @@ and compile_prim_invocation (env : E.t) ae p es at = let (set_meth_pair, get_meth_pair) = new_local env "meth_pair" in let (set_arg, get_arg) = new_local env "arg" in let _, _, _, ts, _ = Type.as_func e1.note.Note.typ in + let has attr attrs = None <> List.find_opt (fun Type.{lab; _} -> attr = lab) attrs in let add_cycles = Type.(match as_obj par.note.Note.typ with - | Object, [] -> Internals.add_cycles env ae (* legacy *) - | _ -> compile_exp_vanilla env ae par ^^ Object.load_idx env par.note.Note.typ "cycles" ^^ Cycles.add env) (* parenthetical *) - in + | Object, attrs when has "cycles" attrs -> compile_exp_vanilla env ae par ^^ Object.load_idx env par.note.Note.typ "cycles" ^^ Cycles.add env (* parenthetical FIXME: effects! *) + | _ -> Internals.add_cycles env ae) (* legacy *) in + let add_timeout = Type.(match as_obj par.note.Note.typ with + | Object, attrs when has "timeout" attrs -> compile_exp_vanilla env ae par ^^ Object.load_idx env par.note.Note.typ "timeout" ^^ BitTagged.untag_i32 __LINE__ env Type.Nat32 ^^ IC.system_call env "call_with_best_effort_response" (* parenthetical FIXME: effects! *) + | _ -> G.nop) in StackRep.of_arity return_arity, code1 ^^ StackRep.adjust env fun_sr SR.Vanilla ^^ set_meth_pair ^^ compile_exp_vanilla env ae e2 ^^ set_arg ^^ - FuncDec.ic_call_one_shot env ts get_meth_pair get_arg add_cycles + FuncDec.ic_call_one_shot env ts get_meth_pair get_arg (add_cycles ^^ add_timeout) end (* Operators *) diff --git a/test/run-drun/ok/par.tc.ok b/test/run-drun/ok/par.tc.ok index a4c453f17d3..9b5cf6f072e 100644 --- a/test/run-drun/ok/par.tc.ok +++ b/test/run-drun/ok/par.tc.ok @@ -1 +1 @@ -par.mo:55.9-55.67: warning [M0204], unrecognised attribute yeah in parenthetical note +par.mo:56.9-56.67: warning [M0204], unrecognised attribute yeah in parenthetical note diff --git a/test/run-drun/par.mo b/test/run-drun/par.mo index 217dbc8e74c..09006a38666 100644 --- a/test/run-drun/par.mo +++ b/test/run-drun/par.mo @@ -14,6 +14,7 @@ actor A { }; public func oneshot() { + assert 0 : Nat64 == replyDeadline(); debugPrint ("oneshot: " # debug_show(Cycles.available())); }; @@ -67,6 +68,7 @@ actor A { debugPrint "test3()"; oneshot(); (with cycles = 3456) oneshot(); + (with timeout = 5) oneshot(); // FIXME: DUBIOUS! }; public func test4() : async () { From dc37044005a29531e04cec7b2ceb36b59c72f1a5 Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Tue, 10 Dec 2024 17:32:22 +0100 Subject: [PATCH 127/127] `oneshot` tests actually work! --- test/run-drun/ok/par.drun-run.ok | 10 ++++++++-- test/run-drun/par.mo | 7 ++++--- 2 files changed, 12 insertions(+), 5 deletions(-) diff --git a/test/run-drun/ok/par.drun-run.ok b/test/run-drun/ok/par.drun-run.ok index 443fecf80dd..151a08fe05c 100644 --- a/test/run-drun/ok/par.drun-run.ok +++ b/test/run-drun/ok/par.drun-run.ok @@ -6,8 +6,14 @@ ingress Completed: Reply: 0x4449444c0000 debug.print: test2() ingress Completed: Reply: 0x4449444c0000 debug.print: test3() -debug.print: oneshot: 0 -debug.print: oneshot: 3_456 +debug.print: oneshot deadline set: false +debug.print: oneshot cycles: 0 +debug.print: oneshot deadline set: false +debug.print: oneshot cycles: 3_456 +debug.print: oneshot deadline set: true +debug.print: oneshot cycles: 0 +debug.print: oneshot deadline set: true +debug.print: oneshot cycles: 4_567 ingress Completed: Reply: 0x4449444c0000 debug.print: test4() debug.print: rawable: 0 diff --git a/test/run-drun/par.mo b/test/run-drun/par.mo index 09006a38666..81f6b457231 100644 --- a/test/run-drun/par.mo +++ b/test/run-drun/par.mo @@ -14,8 +14,8 @@ actor A { }; public func oneshot() { - assert 0 : Nat64 == replyDeadline(); - debugPrint ("oneshot: " # debug_show(Cycles.available())); + debugPrint ("oneshot deadline set: " # debug_show(0 != replyDeadline())); + debugPrint ("oneshot cycles: " # debug_show(Cycles.available())); }; public func rawable() : async () { @@ -68,7 +68,8 @@ actor A { debugPrint "test3()"; oneshot(); (with cycles = 3456) oneshot(); - (with timeout = 5) oneshot(); // FIXME: DUBIOUS! + (with timeout = 5) oneshot(); + (with timeout = 5; cycles = 4567) A.oneshot(); }; public func test4() : async () {