feat: parenthetical syntax for cycles, timeout etc.
#4608
+770
−360
There are no files selected for viewing
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
|
|
@@ -219,6 +219,7 @@ | |
| 'break' <id> <exp_nullary>? | ||
| 'continue' <id> | ||
| 'debug' <exp_nest> | ||
| '(' <exp_post>? 'with' <list(<exp_field>, ';')> ')' <exp_nest> | ||
|
There was a problem hiding this comment. Thoughts on using There was a problem hiding this comment. Sorry for missing this comment for some time... Yeah, it is a nice consistency argument. I was stealing the syntax from the record field separators, but I guess comma works as well. Will try and report back. @crusso any gut feelings about this? There was a problem hiding this comment. I'd stick with There was a problem hiding this comment. Yes, they are fields, but where is it written that they cannot be separated by commas? ;-) Just playing the devil's advocate. Anyway, I have started a branch to get a feeling for the suggestion: #4782. I am not married to either way. |
||
| 'if' <exp_nullary> <exp_nest> | ||
| 'if' <exp_nullary> <exp_nest> 'else' <exp_nest> | ||
| 'try' <exp_nest> <catch> | ||
|
|
||
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
|
|
@@ -2021,7 +2021,7 @@ module Tagged = struct | |
| | T (* (T,+) *) | ||
| | S (* shared ... -> ... *) | ||
| type blob_sort = | ||
| | B (* Blob *) | ||
| | T (* Text *) | ||
| | P (* Principal *) | ||
| | A (* actor { ... } *) | ||
|
|
@@ -2250,6 +2250,15 @@ module Tagged = struct | |
| set_tag ^^ | ||
| go cases | ||
|
|
||
| (* like branch_default_with but the tag is known statically *) | ||
|
There was a problem hiding this comment. These changes need to be transported to |
||
| let branch_with env retty = function | ||
| | [] -> G.i Unreachable | ||
| | [_, code] -> code | ||
| | (_, code) :: cases -> | ||
| let (set_o, get_o) = new_local env "o" in | ||
| let prep (t, code) = (t, get_o ^^ code) | ||
| in set_o ^^ get_o ^^ branch_default env retty (get_o ^^ code) (List.map prep cases) | ||
|
|
||
| let allocation_barrier env = | ||
| (if !Flags.gc_strategy = Flags.Incremental then | ||
| E.call_import env "rts" "allocation_barrier" | ||
|
|
@@ -2411,12 +2420,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, | ||
| (* NB: even ?null does not require allocation: We use a static | ||
| singleton for that: *) | ||
| compile_unboxed_const (vanilla_lit env (null_vanilla_lit env)) | ||
| ; Some, | ||
| obj env Some [get_x] | ||
| ] | ||
| ) | ||
| ) | ||
|
|
@@ -2540,7 +2550,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 ^^ FIXME: NOT needed, accessing immut slots*) | ||
|
There was a problem hiding this comment. Are you sure this is ok? I'd first verify with @luc. Also, not related to this PR at all. There was a problem hiding this comment. have this in a separate PR? |
||
| Tagged.load_field env (funptr_field env) ^^ | ||
| (* All done: Call! *) | ||
| let table_index = 0l in | ||
|
|
@@ -5056,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) []; | ||
|
|
@@ -5508,7 +5519,7 @@ module IC = struct | |
| | Flags.(ICMode | RefMode) -> | ||
| system_call env "call_cycles_add128" | ||
| | _ -> | ||
| E.trap_with env "cannot add cycles when running locally" | ||
|
|
||
|
|
||
| let cycles_accept env = | ||
| match E.mode env with | ||
|
|
@@ -9393,16 +9404,21 @@ end (* Var *) | |
| that requires top-level cps conversion; | ||
| use new prims instead *) | ||
| module Internals = struct | ||
| let call_prelude_function_with_args env ae var args = | ||
| match VarEnv.lookup_var ae var with | ||
| | Some (VarEnv.Const (_, Const.Fun (mk_fi, _))) -> | ||
| compile_unboxed_zero ^^ (* A dummy closure *) | ||
| args ^^ | ||
| G.i (Call (nr (mk_fi ()))) | ||
| | _ -> assert false | ||
|
|
||
| let call_prelude_function env ae var = | ||
| call_prelude_function_with_args env ae var G.nop | ||
|
|
||
| let add_cycles env ae = call_prelude_function env ae "@add_cycles" | ||
| let reset_cycles env ae = call_prelude_function env ae "@reset_cycles" | ||
| let reset_refund env ae = call_prelude_function env ae "@reset_refund" | ||
| let pass_cycles env ae = call_prelude_function_with_args env ae "@pass_cycles" | ||
| end | ||
|
|
||
| (* This comes late because it also deals with messages *) | ||
|
|
@@ -10870,7 +10886,7 @@ and compile_prim_invocation (env : E.t) ae p es at = | |
|
|
||
| begin match p, es with | ||
| (* Calls *) | ||
| | 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 | ||
|
|
@@ -10884,8 +10900,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 | 1), _ -> true | ||
| | n, PrimE (TupPrim, es) when List.length es = n -> true | ||
| | _, _ -> false | ||
| end | ||
|
|
@@ -10916,18 +10931,23 @@ and compile_prim_invocation (env : E.t) ae p es at = | |
| StackRep.of_arity return_arity, | ||
|
|
||
| code1 ^^ | ||
| 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) | ||
| | _, Type.Local -> | ||
| 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 *) | ||
| compile_exp_as env ae (StackRep.of_arity n_args) e2 ^^ | ||
| get_clos ^^ | ||
| Closure.call_closure env n_args return_arity | ||
|
|
@@ -10938,8 +10958,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 = 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 ^^ | ||
|
|
@@ -12112,24 +12134,27 @@ and compile_prim_invocation (env : E.t) ae p es at = | |
| | ICCallerPrim, [] -> | ||
| SR.Vanilla, IC.caller env | ||
|
|
||
| | ICCallPrim setup, [f;e;k;r;c] -> | ||
| SR.unit, begin | ||
| (* TBR: Can we do better than using the notes? *) | ||
| let _, _, _, ts1, _ = Type.as_func f.note.Note.typ in | ||
| 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 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 ^^ | ||
| compile_exp_vanilla env ae r ^^ set_r ^^ | ||
| 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 | ||
|
|
@@ -12187,6 +12212,29 @@ and compile_prim_invocation (env : E.t) ae p es at = | |
| SR.Vanilla, Cycles.refunded env | ||
| | SystemCyclesBurnPrim, [e1] -> | ||
| SR.Vanilla, compile_exp_vanilla env ae e1 ^^ Cycles.burn env | ||
| | ICCyclesPrim, [] -> | ||
|
There was a problem hiding this comment. This is not an idempotent operation, so we have to be careful to not call it twice. E.g. it fails for paired up environment+parenthetical. There was a problem hiding this comment. This should return two options. Possibly just the |
||
| SR.Vanilla, | ||
| G.i (LocalGet (nr 0l)) ^^ (* closed-over bindings *) | ||
| G.if1 I32Type | ||
| begin | ||
| G.i (LocalGet (nr 0l)) ^^ | ||
| Tagged.branch_with env [I32Type] | ||
| [ Tagged.Closure, | ||
| G.i Drop ^^ | ||
| Opt.null_lit env | ||
|
There was a problem hiding this comment. use |
||
| ; Tagged.(Array T), | ||
| Opt.inject_simple env (Arr.load_field env 0l) ^^ | ||
| G.i (LocalGet (nr 0l)) ^^ | ||
| Arr.load_field env 1l ^^ | ||
| G.i (LocalSet (nr 0l)) | ||
| ; Tagged.Object, | ||
| Opt.inject_simple env G.nop | ||
|
There was a problem hiding this comment. Don't care storing back anything, as there is no captured environment. |
||
| ] | ||
| end | ||
| (Opt.null_lit 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 | ||
|
|
@@ -12360,15 +12408,27 @@ 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 (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 | ||
| 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 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 (*FIXME: effects?!*)) | ||
| | _ -> Internals.pass_cycles env ae (Opt.null_lit env) in | ||
| 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 ^^ | ||
| Tagged.load_forwarding_pointer env ^^ | ||
| set_future ^^ | ||
|
|
@@ -12384,7 +12444,7 @@ and compile_exp_with_hint (env : E.t) ae sr_hint exp = | |
| get_k | ||
| get_r | ||
| get_c | ||
| (add_cycles ^^ add_timeout) | ||
| | ActorE (ds, fs, _, _) -> | ||
| fatal "Local actors not supported by backend" | ||
| | NewObjE (Type.(Object | Module | Memory) as _sort, fs, _) -> | ||
|
|
||
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Oops, something went wrong.
Oops, something went wrong.
Add this suggestion to a batch that can be applied as a single commit.
This suggestion is invalid because no changes were made to the code.
Suggestions cannot be applied while the pull request is closed.
Suggestions cannot be applied while viewing a subset of changes.
Only one suggestion per line can be applied in a batch.
Add this suggestion to a batch that can be applied as a single commit.
Applying suggestions on deleted lines is not supported.
You must change the existing code in this line in order to create a valid suggestion.
Outdated suggestions cannot be applied.
This suggestion has been applied or marked resolved.
Suggestions cannot be applied from pending reviews.
Suggestions cannot be applied on multi-line comments.
Suggestions cannot be applied while the pull request is queued to merge.
Suggestion cannot be applied right now. Please check back later.
There was a problem hiding this comment.
Choose a reason for hiding this comment
The reason will be displayed to describe this comment to others. Learn more.
don't forget to revert