From 132b4b48a6515bcf3131b66bf0a95192bfa0a517 Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Thu, 25 Jul 2024 10:13:10 +0200 Subject: [PATCH] feat: `finally` to also clean up after trapping continuations (#4507) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Introduces an optional `finally` clause to `try` expressions that can be used for disciplined (structured) resource management. The clause comprises a unit-valued expression (or block) that may not perform sends (or similar). It gets executed for all control paths that leave the `try`-expression, i.e. `return`, `break`, etc. code paths. For nested `try` expressions the cleanups are performed in innermost to outermost order. For last-resort cleanups (i.e. code paths trapping after an `await`) the replica invokes the callback registered as `ic0.call_on_cleanup`, and this will result in the execution of (exclusively) the `finally` blocks in (dynamic) scope. This is a new mechanism in Motoko, which was not possible to achieve earlier, and puts certain resource deallocations (e.g. of acquired locks) under the programmer's control. ----------------- TODO: - [ ] [invoke cleanup from the interpreter](https://github.com/dfinity/motoko/pull/4507/files/51bb8a1933bbf2c509447032f1ba26b8f91fa4e0#r1658678631) - [ ] make `catch` optional (non-trapping when missing) — #4600 - well, this was not really needed as pattern-match failure would just re-`throw`, so we were fine. Optimised, though. - [x] remaining FIXMEs (`arrange.ml`, etc.) - [x] `Triv` in `try` (respect edges) - [x] fix fallout - [x] forbid control-flow edges out of `finally` blocks - [x] remove all aliasing from IR - [ ] use `meta` (would `assert` currently, thus causing minor code duplication) — could be follow-up PR - [x] handle `Throw` and regular continuations in `await.ml` (instead of desugaring) - [x] adjust (AST, IR)-interpreter - ❗️this is necessary when there is no `catch`, as the exception will escape - how are label continuations invoked in the backend? (I need to know for the _last-resort callback_) - have a new `context` key sort `Cleanup`, stack up continuations of finally blocks only - extend the `kr` in `await.ml` to `krc` (`CPSAwait`), pass `Cleanup` continuations as `c` - add new primitive to compiler to set the last-resort field (not needed) - in `async.ml` lower `CPSAwait` to that too - [x] adapt `check_ir.ml`, etc. - [x] tests with `await*` - [x] fix up the syntax part - `do` ... `finally` (when there is no `catch` clause necessary) - ~means: `TryE` needs `cases list option`~ - type checking for the `finally` clause - [x] unit result - [x] trivial effect (actually Claudio made this capability-based) - [ ] that the `try` block has `await` effect — nope! - [x] other type than unit for `try` - `OtherPrim "call_raw"` + tests — nope! - `cps_asyncE` similarly to `CallPrim/3` — nope! - highlighting of `finally` - [x] for `emacs` - [x] for VSCode → https://github.com/dfinity/vscode-motoko/pull/288 - [x] GitHub highlighter - [x] Changelog (breaking change, new keyword) - [x] Docs - [ ] adapt best practices: https://internetcomputer.org/docs/current/developer-docs/security/security-best-practices/inter-canister-calls#recommendation - [ ] adapt Motoko examples where locking happens --- Building.md | 26 +- Changelog.md | 24 ++ doc/md/examples/grammar.txt | 2 + doc/md/reference/language-manual.md | 10 +- emacs/motoko-mode.el | 1 + rts/motoko-rts/src/continuation_table.rs | 2 +- src/codegen/compile.ml | 80 +++-- src/gen-grammar/grammar.sed | 1 + src/idllib/escape.ml | 1 + src/ir_def/arrange_ir.ml | 7 +- src/ir_def/check_ir.ml | 44 +-- src/ir_def/construct.ml | 54 ++-- src/ir_def/construct.mli | 15 +- src/ir_def/freevars.ml | 4 +- src/ir_def/ir.ml | 6 +- src/ir_def/ir_effect.ml | 9 +- src/ir_def/rename.ml | 6 +- src/ir_interpreter/interpret_ir.ml | 30 +- src/ir_passes/async.ml | 187 ++++++----- src/ir_passes/await.ml | 118 ++++--- src/ir_passes/const.ml | 10 +- src/ir_passes/eq.ml | 8 +- src/ir_passes/erase_typ_field.ml | 4 +- src/ir_passes/show.ml | 10 +- src/ir_passes/tailcall.ml | 9 +- src/lang_utils/error_codes.ml | 2 +- src/lang_utils/error_codes/M0037.md | 19 ++ src/lang_utils/error_codes/M0199.md | 2 - src/lib/lib.ml | 11 +- src/lib/lib.mli | 1 + src/lowering/desugar.ml | 15 +- src/mo_def/arrange.ml | 3 +- src/mo_def/syntax.ml | 3 +- src/mo_frontend/definedness.ml | 3 +- src/mo_frontend/error_reporting.ml | 1 + src/mo_frontend/parser.mly | 14 +- src/mo_frontend/printers.ml | 1 + src/mo_frontend/source_lexer.mll | 1 + src/mo_frontend/source_token.ml | 3 + src/mo_frontend/traversals.ml | 4 +- src/mo_frontend/typing.ml | 18 +- src/mo_interpreter/interpret.ml | 17 +- src/prelude/internals.mo | 21 +- src/viper/traversals.ml | 2 +- test/fail/ok/try-finally.tc.ok | 9 + test/fail/ok/try-finally.tc.ret.ok | 1 + test/fail/try-finally.mo | 37 +++ test/run-drun/ok/try-finally-bug.tc.ok | 1 + test/run-drun/ok/try-finally-bug.tc.ret.ok | 1 + test/run-drun/ok/try-finally.drun-run.ok | 110 +++++++ test/run-drun/ok/try-finally.run-ir.ok | 60 ++++ test/run-drun/ok/try-finally.run-low.ok | 60 ++++ test/run-drun/ok/try-finally.run.ok | 60 ++++ test/run-drun/try-finally-bug.mo | 21 ++ test/run-drun/try-finally.mo | 359 +++++++++++++++++++++ 55 files changed, 1218 insertions(+), 310 deletions(-) create mode 100644 src/lang_utils/error_codes/M0037.md create mode 100644 test/fail/ok/try-finally.tc.ok create mode 100644 test/fail/ok/try-finally.tc.ret.ok create mode 100644 test/fail/try-finally.mo create mode 100644 test/run-drun/ok/try-finally-bug.tc.ok create mode 100644 test/run-drun/ok/try-finally-bug.tc.ret.ok create mode 100644 test/run-drun/ok/try-finally.drun-run.ok create mode 100644 test/run-drun/ok/try-finally.run-ir.ok create mode 100644 test/run-drun/ok/try-finally.run-low.ok create mode 100644 test/run-drun/ok/try-finally.run.ok create mode 100644 test/run-drun/try-finally-bug.mo create mode 100644 test/run-drun/try-finally.mo diff --git a/Building.md b/Building.md index 56ab062938d..2c210777c0f 100644 --- a/Building.md +++ b/Building.md @@ -56,11 +56,11 @@ For more details on our CI and CI setup, see `CI.md`. ## Making releases -We make frequent releases, at least weekly. The steps to make a release (say, version 0.11.2) are: +We make frequent releases, at least weekly. The steps to make a release (say, version 0.12.1) are: * Make sure that the top section of `Changelog.md` has a title like - ## 0.11.2 (2024-02-29) + ## 0.12.1 (2024-07-29) with today’s date. @@ -75,20 +75,20 @@ We make frequent releases, at least weekly. The steps to make a release (say, ve If not, create and merge a separate PR to update the doc (adding any new files) and goto step 0. - * Define a shell variable `export MOC_MINOR=2` + * Define a shell variable `export MOC_MINOR=1` - * Look at `git log --first-parent 0.11.$(expr $MOC_MINOR - 1)..HEAD` and check + * Look at `git log --first-parent 0.12.$(expr $MOC_MINOR - 1)..HEAD` and check that everything relevant is mentioned in the changelog section, and possibly clean it up a bit, curating the information for the target audience. - * `git commit -am "chore: Releasing 0.11."$MOC_MINOR` + * `git commit -am "chore: Releasing 0.12."$MOC_MINOR` * Create a PR from this commit, and label it `automerge-squash`. E.g. - with `git push origin HEAD:$USER/0.11.$MOC_MINOR`. Mergify will + with `git push origin HEAD:$USER/0.12.$MOC_MINOR`. Mergify will merge it into `master` without additional approval, but it will take some time as the title (version number) enters into the `nix` dependency tracking. * `git switch master; git pull --rebase`. The release commit should be your `HEAD` - * `git tag 0.11.$MOC_MINOR -m "Motoko 0.11."$MOC_MINOR` - * `git push origin 0.11.$MOC_MINOR` + * `git tag 0.12.$MOC_MINOR -m "Motoko 0.12."$MOC_MINOR` + * `git push origin 0.12.$MOC_MINOR` Pushing the tag should cause GitHub Actions to create a “Release” on the GitHub project. This will fail if the changelog is not in order (in this case, fix and @@ -102,12 +102,12 @@ branch to the `next-moc` branch. * Wait ca. 5min after releasing to give the CI/CD pipeline time to upload the release artifacts * Change into `motoko-base` * `git switch next-moc; git pull` -* `git switch -c $USER/update-moc-0.11.$MOC_MINOR` +* `git switch -c $USER/update-moc-0.12.$MOC_MINOR` * Update the `CHANGELOG.md` file with an entry at the top * Update the `moc_version` env variable in `.github/workflows/{ci, package-set}.yml` and `mops.toml` to the new released version: - `perl -pi -e "s/moc_version: \"0\.11\.\\d+\"/moc_version: \"0.11.$MOC_MINOR\"/g; s/moc = \"0\.11\.\\d+\"/moc = \"0.11.$MOC_MINOR\"/g; s/version = \"0\.11\.\\d+\"/version = \"0.11.$MOC_MINOR\"/g" .github/workflows/ci.yml .github/workflows/package-set.yml mops.toml` -* `git add .github/ CHANGELOG.md mops.toml && git commit -m "Motoko 0.11."$MOC_MINOR` + `perl -pi -e "s/moc_version: \"0\.12\.\\d+\"/moc_version: \"0.12.$MOC_MINOR\"/g; s/moc = \"0\.12\.\\d+\"/moc = \"0.12.$MOC_MINOR\"/g; s/version = \"0\.12\.\\d+\"/version = \"0.12.$MOC_MINOR\"/g" .github/workflows/ci.yml .github/workflows/package-set.yml mops.toml` +* `git add .github/ CHANGELOG.md mops.toml && git commit -m "Motoko 0.12."$MOC_MINOR` * Revise `CHANGELOG.md`, adding a top entry for the release * You can `git push` now @@ -117,8 +117,8 @@ repo by a scheduled `niv-updater-action`. Finally tag the base release (so the documentation interpreter can do the right thing): * `git switch master && git pull` -* `git tag moc-0.11.$MOC_MINOR` -* `git push origin moc-0.11.$MOC_MINOR` +* `git tag moc-0.12.$MOC_MINOR` +* `git push origin moc-0.12.$MOC_MINOR` If you want to update the portal documentation, typically to keep in sync with a `dfx` release, follow the instructions in https://github.com/dfinity/portal/blob/master/MAINTENANCE.md. diff --git a/Changelog.md b/Changelog.md index 76c46edcebe..345a3383fd8 100644 --- a/Changelog.md +++ b/Changelog.md @@ -1,5 +1,29 @@ # Motoko compiler changelog +## 0.12.0 (to come) + +* motoko (`moc`) + + * feat: `finally` clauses for `try` expressions (#4507). + + A trailing `finally` clause to `try`/`catch` expressions facilitates structured + resource deallocation (e.g. acquired locks, etc.) and similar cleanups in the + presence of control-flow expressions (`return`, `break`, `continue`, `throw`). + Additionally, in presence of `finally` the `catch` clause becomes optional and + and any uncaught error from the `try` block will be propagated, after executing the `finally` block. + + _Note_: `finally`-expressions that are in scope will be executed even if an execution + path _following_ an `await`-expression traps. This feature, formerly not available in Motoko, + allows programmers to implement cleanups even in the presence of traps. For trapping + execution paths prior to any `await`, the replica-provided state roll-back mechanism + ensures that no cleanup is required. + + The relevant security best practices are accessible at + https://internetcomputer.org/docs/current/developer-docs/security/security-best-practices/inter-canister-calls#recommendation + + BREAKING CHANGE (Minor): `finally` is now a reserved keyword, + programs using this identifier will break. + ## 0.11.3 (2024-07-16) * motoko (`moc`) diff --git a/doc/md/examples/grammar.txt b/doc/md/examples/grammar.txt index 9b30a88bff1..24440c86f9e 100644 --- a/doc/md/examples/grammar.txt +++ b/doc/md/examples/grammar.txt @@ -217,6 +217,8 @@ 'if' 'if' 'else' 'try' + 'try' 'finally' + 'try' 'finally' 'throw' 'switch' '{' , ';')> '}' 'while' diff --git a/doc/md/reference/language-manual.md b/doc/md/reference/language-manual.md index 02ad8d3f0d2..9662e81e2db 100644 --- a/doc/md/reference/language-manual.md +++ b/doc/md/reference/language-manual.md @@ -91,7 +91,7 @@ The following keywords are reserved and may not be used as identifiers: ``` bnf actor and assert async async* await await* break case catch class -composite continue debug debug_show do else flexible false for +composite continue debug debug_show do else false flexible finally for from_candid func if ignore import in module not null object or label let loop private public query return shared stable switch system throw to_candid true try type var while with @@ -514,6 +514,9 @@ The syntax of an expression is as follows: await* Await a delayed computation (only in async) throw Raise an error (only in async) try catch Catch an error (only in async) + try finally Guard with cleanup + try catch finally + Catch an error (only in async) and cleanup assert Assertion : Type annotation Declaration @@ -2547,6 +2550,11 @@ Because the [`Error`](../base/Error.md) type is opaque, the pattern match cannot ::: +The `try` expression can be provided with a `finally` cleanup clause to facilitate structured rollback of temporary state changes (e.g. to release a lock). +The preceding `catch` clause may be omitted in the presence of a `finally` clause. + +This form is `try (catch )? finally `, and evaluation proceeds as above with the crucial addition that every control-flow path leaving `` or `` will execute the unit-valued `` before the entire `try` expression produces its result. The cleanup expression will additionally also be executed when the processing after an intervening `await` (directly, or indirectly as `await*`) traps. + See [Error type](#error-type). ### Assert diff --git a/emacs/motoko-mode.el b/emacs/motoko-mode.el index af0aebac1cb..2ca96a52c87 100644 --- a/emacs/motoko-mode.el +++ b/emacs/motoko-mode.el @@ -47,6 +47,7 @@ "debug" "debug_show" "else" + "finally" "flexible" "for" "from_candid" diff --git a/rts/motoko-rts/src/continuation_table.rs b/rts/motoko-rts/src/continuation_table.rs index b0be5f4dbda..11b124ede74 100644 --- a/rts/motoko-rts/src/continuation_table.rs +++ b/rts/motoko-rts/src/continuation_table.rs @@ -109,7 +109,7 @@ pub unsafe fn remember_continuation(mem: &mut M, ptr: Value) -> u32 { // Position of the future in explicit self-send ContinuationTable entries // Invariant: keep this synchronised with compiler.ml (see future_array_index) -const FUTURE_ARRAY_INDEX: u32 = 2; +const FUTURE_ARRAY_INDEX: u32 = 3; #[no_mangle] pub unsafe extern "C" fn peek_future_continuation(idx: u32) -> Value { diff --git a/src/codegen/compile.ml b/src/codegen/compile.ml index 29f2f8a857b..13bbcd16083 100644 --- a/src/codegen/compile.ml +++ b/src/codegen/compile.ml @@ -9149,39 +9149,39 @@ module FuncDec = struct )) let message_start env sort = match sort with - | Type.Shared Type.Write -> - Lifecycle.trans env Lifecycle.InUpdate - | Type.Shared Type.Query -> - Lifecycle.trans env Lifecycle.InQuery - | Type.Shared Type.Composite -> - Lifecycle.trans env Lifecycle.InComposite + | Type.(Shared Write) -> + Lifecycle.(trans env InUpdate) + | Type.(Shared Query) -> + Lifecycle.(trans env InQuery) + | Type.(Shared Composite) -> + Lifecycle.(trans env InComposite) | _ -> assert false let message_cleanup env sort = match sort with - | Type.Shared Type.Write -> + | Type.(Shared Write) -> GC.collect_garbage env ^^ - Lifecycle.trans env Lifecycle.Idle - | Type.Shared Type.Query -> - Lifecycle.trans env Lifecycle.PostQuery - | Type.Shared Type.Composite -> + Lifecycle.(trans env Idle) + | Type.(Shared Query) -> + Lifecycle.(trans env PostQuery) + | Type.(Shared Composite) -> (* Stay in composite query state such that callbacks of composite queries can also use the memory reserve. The state is isolated since memory changes of queries are rolled back by the IC runtime system. *) - Lifecycle.trans env Lifecycle.InComposite + Lifecycle.(trans env InComposite) | _ -> assert false let callback_start env = - Lifecycle.is_in env Lifecycle.InComposite ^^ + Lifecycle.(is_in env InComposite) ^^ G.if0 (G.nop) - (message_start env (Type.Shared Type.Write)) + (message_start env Type.(Shared Write)) let callback_cleanup env = - Lifecycle.is_in env Lifecycle.InComposite ^^ + Lifecycle.(is_in env InComposite) ^^ G.if0 (G.nop) - (message_cleanup env (Type.Shared Type.Write)) + (message_cleanup env Type.(Shared Write)) let compile_const_message outer_env outer_ae sort control args mk_body ret_tys at : E.func_with_names = let ae0 = VarEnv.mk_fun_ae outer_ae in @@ -9383,7 +9383,7 @@ module FuncDec = struct (* result is a function that accepts a list of closure getters, from which the first and second must be the reply and reject continuations. *) fun closure_getters -> - let (set_cb_index, get_cb_index) = new_local env "cb_index" in + let set_cb_index, get_cb_index = new_local env "cb_index" in Arr.lit env closure_getters ^^ ContinuationTable.remember env ^^ set_cb_index ^^ @@ -9411,7 +9411,12 @@ module FuncDec = struct Func.define_built_in env name ["env", I32Type] [] (fun env -> G.i (LocalGet (nr 0l)) ^^ ContinuationTable.recall env ^^ - G.i Drop); + Arr.load_field env 2l ^^ (* get the cleanup closure *) + let set_closure, get_closure = new_local env "closure" in + set_closure ^^ get_closure ^^ + Closure.prepare_closure_call env ^^ + get_closure ^^ + Closure.call_closure env 0 0); compile_unboxed_const (E.add_fun_ptr env (E.built_in env name)) let ic_call_threaded env purpose get_meth_pair push_continuations @@ -9460,29 +9465,29 @@ module FuncDec = struct | _ -> E.trap_with env (Printf.sprintf "cannot perform %s when running locally" purpose) - let ic_call env ts1 ts2 get_meth_pair get_arg get_k get_r = + let ic_call env ts1 ts2 get_meth_pair get_arg get_k get_r get_c = ic_call_threaded env "remote call" get_meth_pair - (closures_to_reply_reject_callbacks env ts2 [get_k; get_r]) + (closures_to_reply_reject_callbacks env ts2 [get_k; get_r; get_c]) (fun _ -> get_arg ^^ Serialization.serialize env ts1) - let ic_call_raw env get_meth_pair get_arg get_k get_r = + let ic_call_raw env get_meth_pair get_arg get_k get_r get_c = ic_call_threaded env "raw call" get_meth_pair - (closures_to_raw_reply_reject_callbacks env [get_k; get_r]) + (closures_to_raw_reply_reject_callbacks env [get_k; get_r; get_c]) (fun _ -> get_arg ^^ Blob.as_ptr_len env) - let ic_self_call env ts get_meth_pair get_future get_k get_r = + let ic_self_call env ts get_meth_pair get_future get_k get_r get_c = ic_call_threaded env "self call" get_meth_pair - (* Storing the tuple away, future_array_index = 2, keep in sync with rts/continuation_table.rs *) - (closures_to_reply_reject_callbacks env ts [get_k; get_r; get_future]) + (* Storing the tuple away, future_array_index = 3, keep in sync with rts/continuation_table.rs *) + (closures_to_reply_reject_callbacks env ts [get_k; get_r; get_c; get_future]) (fun get_cb_index -> get_cb_index ^^ BoxedSmallWord.box env Type.Nat32 ^^ @@ -11783,7 +11788,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;c] -> SR.unit, begin (* TBR: Can we do better than using the notes? *) let _, _, _, ts1, _ = Type.as_func f.note.Note.typ in @@ -11792,19 +11797,22 @@ 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 (set_c, get_c) = new_local env "c" in let add_cycles = Internals.add_cycles env ae 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 ^^ - FuncDec.ic_call env ts1 ts2 get_meth_pair get_arg get_k get_r add_cycles + 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] -> + | ICCallRawPrim, [p;m;a;k;r;c] -> SR.unit, begin - let (set_meth_pair, get_meth_pair) = new_local env "meth_pair" in - let (set_arg, get_arg) = new_local env "arg" in - let (set_k, get_k) = new_local env "k" in - let (set_r, get_r) = new_local env "r" in + let 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 = Internals.add_cycles env ae in compile_exp_vanilla env ae p ^^ compile_exp_vanilla env ae m ^^ Text.to_blob env ^^ @@ -11813,7 +11821,8 @@ and compile_prim_invocation (env : E.t) ae p es at = compile_exp_vanilla env ae a ^^ set_arg ^^ compile_exp_vanilla env ae k ^^ set_k ^^ compile_exp_vanilla env ae r ^^ set_r ^^ - FuncDec.ic_call_raw env get_meth_pair get_arg get_k get_r add_cycles + compile_exp_vanilla env ae c ^^ set_c ^^ + FuncDec.ic_call_raw env get_meth_pair get_arg get_k get_r get_c add_cycles end | ICMethodNamePrim, [] -> @@ -12022,11 +12031,12 @@ 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) -> + | SelfCallE (ts, exp_f, exp_k, exp_r, exp_c) -> SR.unit, let (set_future, get_future) = new_local env "future" in let (set_k, get_k) = new_local env "k" in let (set_r, get_r) = new_local env "r" in + let (set_c, get_c) = new_local env "c" in let mk_body env1 ae1 = compile_exp_as env1 ae1 SR.unit exp_f in let captured = Freevars.captured exp_f in let add_cycles = Internals.add_cycles env ae in @@ -12036,6 +12046,7 @@ and compile_exp_with_hint (env : E.t) ae sr_hint exp = compile_exp_vanilla env ae exp_k ^^ set_k ^^ compile_exp_vanilla env ae exp_r ^^ set_r ^^ + compile_exp_vanilla env ae exp_c ^^ set_c ^^ FuncDec.ic_self_call env ts IC.(get_self_reference env ^^ @@ -12043,6 +12054,7 @@ and compile_exp_with_hint (env : E.t) ae sr_hint exp = get_future get_k get_r + get_c add_cycles | ActorE (ds, fs, _, _) -> fatal "Local actors not supported by backend" diff --git a/src/gen-grammar/grammar.sed b/src/gen-grammar/grammar.sed index 66ca48c061f..ac64fe62668 100644 --- a/src/gen-grammar/grammar.sed +++ b/src/gen-grammar/grammar.sed @@ -53,6 +53,7 @@ s/UNDERSCORE/\'_\'/g s/TYPE/\'type\'/g s/TRY/\'try\'/g s/THROW/\'throw\'/g +s/FINALLY/\'finally\'/g s/TEXT//g s/SWITCH/\'switch\'/g s/SUBOP/\'-\'/g diff --git a/src/idllib/escape.ml b/src/idllib/escape.ml index c5dc2e2aa8b..c2004010b23 100644 --- a/src/idllib/escape.ml +++ b/src/idllib/escape.ml @@ -73,6 +73,7 @@ let is_motoko_keyword = function | "do" | "else" | "false" + | "finally" | "flexible" | "for" | "from_candid" diff --git a/src/ir_def/arrange_ir.ml b/src/ir_def/arrange_ir.ml index 01f07880878..5817a484f01 100644 --- a/src/ir_def/arrange_ir.ml +++ b/src/ir_def/arrange_ir.ml @@ -28,11 +28,12 @@ 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) -> - "SelfCallE" $$ [typ (Type.seq ts); exp exp_f; exp exp_k; exp exp_r] + | SelfCallE (ts, exp_f, exp_k, exp_r, exp_c) -> + "SelfCallE" $$ [typ (Type.seq ts); exp exp_f; exp exp_k; exp exp_r; exp exp_c] | 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) -> "TryE" $$ [exp e] @ List.map case cs + | TryE (e, cs, None) -> "TryE" $$ [exp e] @ List.map case cs + | TryE (e, cs, Some (i, _)) -> "TryE" $$ [exp e] @ List.map case cs @ Atom ";" :: [id i] and system { meta; preupgrade; postupgrade; heartbeat; timer; inspect} = (* TODO: show meta? *) "System" $$ [ diff --git a/src/ir_def/check_ir.ml b/src/ir_def/check_ir.ml index e9c0e0d84a9..1fdae022227 100644 --- a/src/ir_def/check_ir.ml +++ b/src/ir_def/check_ir.ml @@ -22,7 +22,7 @@ let typ = E.typ let immute_typ p = assert (not (T.is_mut (typ p))); - (typ p) + typ p (* Scope *) @@ -549,7 +549,7 @@ 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 - | CPSAwait (s, cont_typ), [a; kr] -> + | CPSAwait (s, cont_typ), [a; krb] -> let (_, t1) = try T.as_async_sub s T.Non (T.normalize (typ a)) with _ -> error env exp.at "CPSAwait expect async arg, found %s" (T.string_of_typ (typ a)) @@ -560,7 +560,7 @@ let rec check_exp env (exp:Ir.exp) : unit = (match ts2 with | [] -> () | _ -> error env exp.at "CPSAwait answer type error"); - typ kr <: T.Tup [cont_typ; T.Func(T.Local, T.Returns, [], [T.catch], ts2)]; + typ krb <: T.(Tup Construct.[cont_typ; err_contT (seq ts2); bail_contT]); t1 <: T.seq ts1; T.seq ts2 <: t; end; @@ -569,12 +569,13 @@ let rec check_exp env (exp:Ir.exp) : unit = check (env.flavor.has_async_typ) "CPSAwait in post-async flavor"; | CPSAsync (s, t0), [exp] -> (match typ exp with - T.Func(T.Local,T.Returns, [tb], - [T.Func(T.Local, T.Returns, [], ts1, []); - T.Func(T.Local, T.Returns, [], [t_error], [])], - []) -> - T.catch <: t_error; - T.Async(s, t0, Type.open_ [t0] (T.seq ts1)) <: t + | T.Func (T.Local, T.Returns, [tb], + T.[Func (Local, Returns, [], ts1, []); + Func (Local, Returns, [], [t_error], []); + Func (Local, Returns, [], [], [])], + []) -> + T.catch <: t_error; + T.Async(s, t0, T.open_ [t0] (T.seq ts1)) <: t | _ -> error env exp.at "CPSAsync unexpected typ"); check (not (env.flavor.has_await)) "CPSAsync await flavor"; check (env.flavor.has_async_typ) "CPSAsync in post-async flavor"; @@ -593,27 +594,29 @@ let rec check_exp env (exp:Ir.exp) : unit = T.Non <: t | ICCallerPrim, [] -> T.caller <: t - | ICCallPrim, [exp1; exp2; k; r] -> + | ICCallPrim, [exp1; exp2; k; r; c] -> let t1 = T.promote (typ exp1) in begin match t1 with | T.Func (sort, T.Replies, _ (*TBR*), arg_tys, ret_tys) -> let t_arg = T.seq arg_tys in typ exp2 <: t_arg; check_concrete env exp.at t_arg; - typ k <: T.Func (T.Local, T.Returns, [], ret_tys, []); - typ r <: T.Func (T.Local, T.Returns, [], [T.error], []); + typ k <: T.(Construct.contT (Tup ret_tys) unit); + typ r <: T.(Construct.err_contT unit); + typ c <: Construct.clean_contT; | T.Non -> () (* dead code, not much to check here *) | _ -> error env exp1.at "expected function type, but expression produces type\n %s" (T.string_of_typ_expand t1) end (* TODO: T.unit <: t ? *) - | ICCallRawPrim, [exp1; exp2; exp3; k; r] -> + | ICCallRawPrim, [exp1; exp2; exp3; k; r; c] -> typ exp1 <: T.principal; typ exp2 <: T.text; typ exp3 <: T.blob; - typ k <: T.Func (T.Local, T.Returns, [], [T.blob], []); - typ r <: T.Func (T.Local, T.Returns, [], [T.error], []); + typ k <: T.(Construct.contT blob unit); + typ r <: T.(Construct.err_contT unit); + typ c <: Construct.clean_contT; T.unit <: t | ICMethodNamePrim, [] -> T.text <: t @@ -718,12 +721,13 @@ let rec check_exp env (exp:Ir.exp) : unit = warn env exp.at "the cases in this switch do not cover all possible values"; *) check_cases env t1 t cases - | TryE (exp1, cases) -> + | TryE (exp1, cases, vt) -> check env.flavor.has_await "try in non-await flavor"; check (env.async <> None) "misplaced try"; check_exp env exp1; typ exp1 <: t; check_cases env T.catch t cases; + Option.iter (fun (_, t) -> t <: Construct.bail_contT) vt | LoopE exp1 -> check_exp { env with lvl = NotTopLvl } exp1; typ exp1 <: T.unit; @@ -793,15 +797,17 @@ 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) -> + | SelfCallE (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; check_exp env exp_k; check_exp env exp_r; + check_exp env exp_c; typ exp_f <: T.unit; - typ exp_k <: T.Func (T.Local, T.Returns, [], ts, []); - typ exp_r <: T.Func (T.Local, T.Returns, [], [T.error], []); + typ exp_k <: T.(Construct.contT (Tup ts) unit); + typ exp_r <: T.(Construct.err_contT unit); + typ exp_c <: Construct.clean_contT; | ActorE (ds, fs, { preupgrade; postupgrade; meta; heartbeat; timer; inspect }, t0) -> (* TODO: check meta *) diff --git a/src/ir_def/construct.ml b/src/ir_def/construct.ml index 8c0a52a2bb9..97a808a7ca9 100644 --- a/src/ir_def/construct.ml +++ b/src/ir_def/construct.ml @@ -15,7 +15,7 @@ let nextN = "next" (* Identifiers *) -type var = (string * T.typ) +type var = id * T.typ let var id typ = (id, typ) @@ -117,8 +117,7 @@ let primE prim es = | OtherPrim "is_controller" -> T.bool | _ -> assert false (* implement more as needed *) in - let effs = List.map eff es in - let eff = List.fold_left max_eff T.Triv effs in + let eff = List.(map eff es |> fold_left max_eff T.Triv) in { it = PrimE (prim, es); at = no_region; note = Note.{ def with typ; eff } @@ -183,22 +182,20 @@ let ic_rejectE e = note = Note.{ def with typ = T.unit; eff = eff e } } -let ic_callE 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 +let ic_callE 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 { it = PrimE (ICCallPrim, es); at = no_region; - note = Note.{ def with typ = T.unit; eff = eff } + note = Note.{ def with typ = T.unit; eff } } -let ic_call_rawE p m a k r = - let es = [p; m; a; k; r] in - let effs = List.map eff es in - let eff = List.fold_left max_eff T.Triv effs in +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 { it = PrimE (ICCallRawPrim, es); at = no_region; - note = Note.{ def with typ = T.unit; eff = eff } + note = Note.{ def with typ = T.unit; eff } } (* tuples *) @@ -245,9 +242,8 @@ let blockE decs exp = match decs' with | [] -> exp | _ -> - let es = List.map dec_eff decs' in let typ = typ exp in - let eff = List.fold_left max_eff (eff exp) es in + let eff = List.(map dec_eff decs' |> fold_left max_eff (eff exp)) in { it = BlockE (decs', exp); at = no_region; note = Note.{ def with typ; eff } @@ -313,7 +309,7 @@ let funcE name sort ctrl typ_binds args typs exp = } let callE exp1 typs exp2 = - let typ = match T.promote (typ exp1) with + let typ = match T.promote (typ exp1) with | T.Func (_sort, control, _, _, ret_tys) -> T.codom control (fun () -> List.hd typs) (List.map (T.open_ typs) ret_tys) | T.Non -> T.Non @@ -412,7 +408,7 @@ let switch_variantE exp1 cases typ1 = at = no_region; note = Note.{ def with typ = typ1; - eff = List.fold_left max_eff (eff exp1) (List.map (fun (l,p,e) -> eff e) cases) + eff = List.(map (fun (l,p,e) -> eff e) cases |> fold_left max_eff (eff exp1)) } } @@ -436,14 +432,13 @@ let switch_textE exp1 cases (pat, exp2) typ1 = note = Note.{ def with typ = typ1; - eff = List.fold_left max_eff (eff exp1) (List.map (fun c -> eff c.it.exp) cs) + eff = List.(map (fun c -> eff c.it.exp) cs |> fold_left max_eff (eff exp1)) } } let tupE exps = - let effs = List.map eff exps in - let eff = List.fold_left max_eff T.Triv effs in + let eff = List.(map eff exps |> fold_left max_eff T.Triv) in { it = PrimE (TupPrim, exps); at = no_region; note = Note.{ def with typ = T.Tup (List.map typ exps); eff }; @@ -632,17 +627,18 @@ let contT typ ans_typ = T.(Func (Local, Returns, [], as_seq typ, as_seq ans_typ) let err_contT ans_typ = T.(Func (Local, Returns, [], [catch], as_seq ans_typ)) +let bail_contT = T.(contT unit unit) (* when `await`ing *) + +let clean_contT = bail_contT (* last-resort replica callback *) + let answerT typ : T.typ = match typ with | T.Func (T.Local, T.Returns, [], ts1, ts2) -> T.seq ts2 | _ -> assert false -let cpsT typ ans_typ = T.(Func (Local, Returns, [], [contT typ ans_typ; err_contT ans_typ], as_seq ans_typ)) - (* Sequence expressions *) -let seqE es = - match es with +let seqE = function | [e] -> e | es -> tupE es @@ -668,7 +664,7 @@ let forall tbs e = let cs = List.map (fun tb -> tb.it.con) tbs in match e.it, e.note.Note.typ with | FuncE (n, s, c1, [], xs, ts, exp), - T.Func ( _, c2, [], ts1, ts2) -> + T.Func (_, c2, [], ts1, ts2) -> { e with it = FuncE(n, s, c1, tbs, xs, ts, exp); note = Note.{ e.note with @@ -679,6 +675,14 @@ let forall tbs e = } | _ -> assert false +(* changing display name of e.g. local lambda *) +let named displ e = + match e.it with + | FuncE (_, s, c1, [], xs, ts, exp) + -> { e with it = FuncE (displ, s, c1, [], xs, ts, exp) } + | _ -> assert false + + (* Lambda application (monomorphic) *) let ( -*- ) exp1 exp2 = callE exp1 [] exp2 diff --git a/src/ir_def/construct.mli b/src/ir_def/construct.mli index 731568f94a2..26387ef5097 100644 --- a/src/ir_def/construct.mli +++ b/src/ir_def/construct.mli @@ -21,8 +21,8 @@ val nextN : Type.lab type var -val var : string -> typ -> var -val id_of_var : var -> string +val var : id -> typ -> var +val id_of_var : var -> id val typ_of_var : var -> typ val arg_of_var : var -> arg val var_of_arg : arg -> var @@ -55,8 +55,8 @@ 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_call_rawE : exp -> exp -> exp -> exp -> exp -> exp +val ic_callE : exp -> exp -> exp -> exp -> exp -> exp +val ic_call_rawE : exp -> exp -> exp -> exp -> exp -> exp -> exp val projE : exp -> int -> exp val optE : exp -> exp val tagE : id -> exp -> exp @@ -127,10 +127,10 @@ val let_no_shadow : var -> exp -> dec list -> dec list val contT : typ -> typ -> typ val err_contT : typ -> typ +val bail_contT : typ +val clean_contT : typ val answerT : typ -> typ (* answer type of a continuation type *) -val cpsT : typ -> typ -> typ - (* Sequence expressions *) val seqE : exp list -> exp @@ -140,7 +140,8 @@ 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 named : string -> exp -> exp (* renaming a function *) +val (-*-) : exp -> exp -> exp (* application *) (* Objects *) diff --git a/src/ir_def/freevars.ml b/src/ir_def/freevars.ml index eb0f49fcc83..36abdb6fe0a 100644 --- a/src/ir_def/freevars.ml +++ b/src/ir_def/freevars.ml @@ -118,8 +118,8 @@ let rec exp e : f = match e.it with | FuncE (x, s, c, tp, as_, t, e) -> under_lambda (exp e /// args as_) | ActorE (ds, fs, u, _) -> actor ds fs u | NewObjE (_, fs, _) -> fields fs - | TryE (e, cs) -> exp e ++ cases cs - | SelfCallE (_, e1, e2, e3) -> under_lambda (exp e1) ++ exp e2 ++ exp e3 + | 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] 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 f58bdb9567a..ebd3852e071 100644 --- a/src/ir_def/ir.ml +++ b/src/ir_def/ir.ml @@ -71,10 +71,10 @@ 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 (* essentially ICCallPrim (FuncE shared…) *) + | SelfCallE of 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 (* try/catch *) + | NewObjE of Type.obj_sort * field list * Type.typ (* make an object *) + | TryE of exp * case list * (id * Type.typ) option (* try/catch/cleanup *) and system = { meta : meta; diff --git a/src/ir_def/ir_effect.ml b/src/ir_def/ir_effect.ml index 169f206fa89..32f86094cd8 100644 --- a/src/ir_def/ir_effect.ml +++ b/src/ir_def/ir_effect.ml @@ -21,7 +21,7 @@ let is_triv phrase = eff phrase = T.Triv let effect_exp (exp: exp) : T.eff = eff exp let is_async_call p exps = - match (p, exps) with + match p, exps with | CallPrim _, [exp1; _] -> T.is_shared_func (typ exp1) || T.is_local_async_func (typ exp1) @@ -29,7 +29,7 @@ let is_async_call p exps = true | _ -> false -(* infer the effect of an expression, assuming all sub-expressions are correctly effect-annotated es*) +(* infer the effect of an expression, assuming all sub-expressions are correctly effect-annotated *) let rec infer_effect_prim p exps = match p, exps with @@ -77,10 +77,11 @@ and infer_effect_exp (exp: exp) : T.eff = effect_exp exp1 | FuncE _ -> T.Triv - | SelfCallE (_, _, exp1, exp2) -> + | SelfCallE (_, _, exp1, exp2, exp3) -> let e1 = effect_exp exp1 in let e2 = effect_exp exp2 in - max_eff e1 e2 + let e3 = effect_exp exp3 in + max_eff e1 (max_eff e2 e3) | ActorE _ -> T.Triv | NewObjE _ -> diff --git a/src/ir_def/rename.ml b/src/ir_def/rename.ml index 0a14e5da22a..4aea8e37ea8 100644 --- a/src/ir_def/rename.ml +++ b/src/ir_def/rename.ml @@ -63,9 +63,9 @@ and exp' rho = function let e' = exp rho' e in FuncE (x, s, c, tp, p', ts, e') | NewObjE (s, fs, t) -> NewObjE (s, fields rho fs, t) - | TryE (e, cs) -> TryE (exp rho e, cases rho cs) - | SelfCallE (ts, e1, e2, e3) -> - SelfCallE (ts, exp rho e1, exp rho e2, exp rho e3) + | 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) 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 f8c245b5769..ee60590b620 100644 --- a/src/ir_interpreter/interpret_ir.ml +++ b/src/ir_interpreter/interpret_ir.ml @@ -338,7 +338,7 @@ and interpret_exp_mut env exp (k : V.value V.cont) = let id = V.as_blob v1 in begin match V.Env.find_opt id !(env.actor_env) with (* not quite correct: On the platform, you can invoke and get a reject *) - | None -> trap exp.at "Unkown actor \"%s\"" id + | None -> trap exp.at "Unknown actor \"%s\"" id | Some actor_value -> let fs = V.as_obj actor_value in match V.Env.find_opt n fs with @@ -446,13 +446,13 @@ 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; cv] -> 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; last_region := exp.at; (* in case the following throws *) let vc = context env in - f (V.Tup[vc; kv; rv]) v2 k + f (V.Tup[vc; kv; rv; cv]) v2 k | ICCallerPrim, [] -> k env.caller | ICStableRead t, [] -> @@ -492,10 +492,19 @@ and interpret_exp_mut env exp (k : V.value V.cont) = interpret_exp env exp1 (fun v1 -> interpret_cases env cases exp.at v1 k ) - | TryE (exp1, cases) -> - let k' = fun v1 -> interpret_catches env cases exp.at v1 k in - let env' = { env with throws = Some k' } in - interpret_exp env' exp1 k + | TryE (exp1, cases, finally_opt) -> + assert env.flavor.has_await; + let k, env = match finally_opt with + | None -> k, env + | Some (id, ty) -> + let exp2 = Construct.(varE (var id ty) -*- unitE ()) in + let pre k v = interpret_exp env exp2 (fun v2 -> V.as_unit v2; k v) in + pre k, + { env with rets = Option.map pre env.rets + ; labs = V.Env.map pre env.labs + ; throws = Option.map pre env.throws } in + let k' v1 = interpret_catches env cases exp.at v1 k in + interpret_exp { env with throws = Some k' } exp1 k | LoopE exp1 -> interpret_exp env exp1 (fun v -> V.as_unit v; interpret_exp env exp k) | LabelE (id, _typ, exp1) -> @@ -527,7 +536,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) -> + | SelfCallE (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 @@ -537,10 +546,11 @@ and interpret_exp_mut env exp (k : V.value V.cont) = (* see code for ICCallPrim *) interpret_exp env exp_k (fun kv -> interpret_exp env exp_r (fun rv -> + interpret_exp env exp_c (fun cv -> let _call_conv, f = V.as_func v in last_region := exp.at; (* in case the following throws *) let vc = context env in - f (V.Tup[vc; kv; rv]) (V.Tup []) k)) + f (V.Tup[vc; kv; rv; cv]) (V.Tup []) k))) | FuncE (x, (T.Shared _ as sort), (T.Replies as control), _typbinds, args, ret_typs, e) -> assert (not env.flavor.has_async_typ); let cc = { sort; control; n_args = List.length args; n_res = List.length ret_typs } in @@ -822,7 +832,7 @@ and interpret_func env at sort x args f c v (k : V.value V.cont) = and interpret_message env at x args f c v (k : V.value V.cont) = let v_caller, v_reply, v_reject = match V.as_tup c with - | [v_caller; v_reply; v_reject] -> v_caller, v_reply, v_reject + | [v_caller; v_reply; v_reject; _v_cleanup] -> v_caller, v_reply, v_reject | _ -> assert false in if env.flags.trace then trace "%s%s" x (string_of_arg env v); diff --git a/src/ir_passes/async.ml b/src/ir_passes/async.ml index 5d4a000cabf..bb4a8d98526 100644 --- a/src/ir_passes/async.ml +++ b/src/ir_passes/async.ml @@ -20,46 +20,49 @@ open Construct a manifest tuple argument extended with a final reply continuation. *) -module ConRenaming = E.Make(struct type t = T.con let compare = Cons.compare end) +module ConRenaming = E.Make(struct type t = con let compare = Cons.compare end) (* Helpers *) -let selfcallE ts e1 e2 e3 = - { it = SelfCallE (ts, e1, e2, e3); +let selfcallE ts e1 e2 e3 e4 = + { it = SelfCallE (ts, e1, e2, e3, e4); at = no_region; - note = Note.{ def with typ = T.unit } } + note = Note.{ def with typ = unit } } -let error_rep_ty = T.(Tup [Variant T.catchErrorCodes; text]) +let error_rep_ty = Tup [Variant catchErrorCodes; text] let errorMessageE e = - projE (primE (CastPrim (T.error, error_rep_ty)) [e]) 1 + projE (primE (CastPrim (error, error_rep_ty)) [e]) 1 let unary typ = [typ] -let nary typ = T.as_seq typ +let nary typ = as_seq typ -let fulfillT as_seq typ = T.Func(T.Local, T.Returns, [], as_seq typ, []) +let fulfillT as_seq typ = Func(Local, Returns, [], as_seq typ, []) -let failT = T.Func(T.Local, T.Returns, [], [T.catch], []) +let failT = err_contT unit +let bailT = bail_contT + +let cleanT = clean_contT let t_async_fut as_seq t = - T.Func (T.Local, T.Returns, [], [fulfillT as_seq t; failT], - [T.sum [ - ("suspend", T.unit); - ("schedule", T.Func(T.Local, T.Returns, [], [], []))]]) + Func (Local, Returns, [], [fulfillT as_seq t; failT; bailT], + [sum [ + ("suspend", unit); + ("schedule", Func(Local, Returns, [], [], []))]]) let t_async_cmp as_seq t = - T.Func (T.Local, T.Returns, [], [fulfillT as_seq t; failT], []) + Func (Local, Returns, [], [fulfillT as_seq t; failT; bailT], []) -let new_async_ret as_seq t = [t_async_fut as_seq t; fulfillT as_seq t; failT] +let new_async_ret as_seq t = [t_async_fut as_seq t; fulfillT as_seq t; failT; cleanT] let new_asyncT = - T.Func ( - T.Local, - T.Returns, - [ { var = "T"; sort = T.Type; bound = T.Any } ], - [], - new_async_ret unary (T.Var ("T", 0))) + (Func ( + Local, + Returns, + [ { var = "T"; sort = Type; bound = Any } ], + [], + new_async_ret unary (Var ("T", 0)))) let new_asyncE () = varE (var "@new_async" new_asyncT) @@ -69,23 +72,26 @@ let new_async t = let async = fresh_var "async" (typ (projE call_new_async 0)) in let fulfill = fresh_var "fulfill" (typ (projE call_new_async 1)) in let fail = fresh_var "fail" (typ (projE call_new_async 2)) in - (async, fulfill, fail), call_new_async + let clean = fresh_var "clean" (typ (projE call_new_async 3)) in + (async, fulfill, fail, clean), call_new_async let new_nary_async_reply ts = (* The async implementation isn't n-ary *) let t = T.seq ts in - let (unary_async, unary_fulfill, fail), call_new_async = new_async t in + let (unary_async, unary_fulfill, fail, clean), call_new_async = new_async t in (* 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] -->* ( + let k = fresh_var "k" (contT u unit) in + let r = fresh_var "r" (err_contT unit) in + let c = fresh_var "b" bail_contT in + [k; r; c] -->* ( varE unary_async -*- (tupE [ [v] -->* (varE k -*- varE v); - varE r + varE r; + varE c; ]) ) in @@ -93,7 +99,7 @@ let new_nary_async_reply ts = | [t1] -> begin match T.normalize t1 with - | T.Tup _ -> + | Tup _ -> (* TODO(#3740): find a better fix than PR #3741 *) (* HACK *) coerce t1 @@ -111,14 +117,15 @@ let new_nary_async_reply ts = in vs -->* (varE unary_fulfill -*- seq_of_vs) in - let async,reply,reject = + let async, reply, reject, cleanup = fresh_var "async" (typ nary_async), fresh_var "reply" (typ nary_reply), - fresh_var "reject" (typ_of_var fail) + fresh_var "reject" (typ_of_var fail), + fresh_var "cleanup" (typ_of_var clean) in - (async, reply, reject), - blockE [letP (tupP [varP unary_async; varP unary_fulfill; varP fail]) call_new_async] - (tupE [nary_async; nary_reply; varE fail]) + (async, reply, reject, cleanup), + blockE [letP (tupP [varP unary_async; varP unary_fulfill; varP fail; varP clean]) call_new_async] + (tupE [nary_async; nary_reply; varE fail; varE clean]) let let_eta e scope = @@ -130,7 +137,7 @@ let let_eta e scope = let is_awaitable_func exp = match typ exp with - | T.Func (T.Shared _, T.Promises, _, _, _) -> true + | Func (Shared _, Promises, _, _, _) -> true | _ -> false (* Given sequence type ts, bind e of type (seq ts) to a @@ -182,14 +189,14 @@ let transform prog = let rec t_typ (t:T.typ) = match t with - | T.Prim _ + | Prim _ | Var _ -> t | Con (c, ts) -> Con (t_con c, List.map t_typ ts) | Array t -> Array (t_typ t) | Tup ts -> Tup (List.map t_typ ts) | Func (s, c, tbs, ts1, ts2) -> - let c' = match c with T.Promises -> T.Replies | _ -> c in + let c' = match c with Promises -> Replies | _ -> c in Func (s, c', List.map t_bind tbs, List.map t_typ ts1, List.map t_typ ts2) | Opt t -> Opt (t_typ t) | Variant fs -> Variant (List.map t_field fs) @@ -209,14 +216,14 @@ let transform prog = and t_kind k = match k with - | T.Abs (typ_binds,typ) -> - T.Abs (t_binds typ_binds, t_typ typ) - | T.Def (typ_binds,typ) -> - T.Def (t_binds typ_binds, t_typ typ) + | Abs (typ_binds,typ) -> + Abs (t_binds typ_binds, t_typ typ) + | Def (typ_binds,typ) -> + Def (t_binds typ_binds, t_typ typ) and t_con c = match Cons.kind c with - | T.Def ([], T.Prim _) -> c + | Def ([], Prim _) -> c | _ -> match ConRenaming.find_opt c (!con_renaming) with | Some c' -> c' @@ -248,84 +255,86 @@ let transform prog = | VarE id -> exp' | AssignE (exp1, exp2) -> AssignE (t_lexp exp1, t_exp exp2) - | PrimE (CPSAwait (Fut, cont_typ), [a; kr]) -> + | PrimE (CPSAwait (Fut, cont_typ), [a; krb]) -> begin match cont_typ with | Func(_, _, [], _, []) -> (* unit answer type, from await in `async {}` *) - (ensureNamed (t_exp kr) (fun vkr -> - let schedule = fresh_var "schedule" (T.Func(T.Local, T.Returns, [], [], [])) in - switch_variantE ((t_exp a) -*- varE vkr) + (ensureNamed (t_exp krb) (fun vkrb -> + let schedule = fresh_var "schedule" (Func(Local, Returns, [], [], [])) in + switch_variantE (t_exp a -*- varE vkrb) [ ("suspend", wildP, unitE()); (* suspend *) ("schedule", varP schedule, (* resume later *) (* try await async (); schedule() catch e -> r(e) *) - (let v = fresh_var "call" T.unit in + (let v = fresh_var "call" unit in letE v - (selfcallE [] (ic_replyE [] (unitE())) (varE schedule) (projE (varE vkr) 1)) - (check_call_perform_status (varE v) (fun e -> projE (varE vkr) 1 -*- e)))) + (selfcallE [] (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)))) ] - T.unit + unit )).it | _ -> assert false end - | PrimE (CPSAwait (Cmp, cont_typ), [a; kr]) -> + | PrimE (CPSAwait (Cmp, cont_typ), [a; krb]) -> begin match cont_typ with | Func(_, _, [], _, []) -> - ((t_exp a) -*- (t_exp kr)).it + (t_exp a -*- t_exp krb).it | _ -> assert false end | PrimE (CPSAsync (Fut, t), [exp1]) -> let t0 = t_typ t in let tb, ts1 = match typ exp1 with - | Func(_,_, [tb], [Func(_, _, [], ts1, []); _], []) -> + | Func(_,_, [tb], [Func(_, _, [], ts1, []); _; _], []) -> tb, List.map t_typ (List.map (T.open_ [t]) ts1) | t -> assert false in - let ((nary_async, nary_reply, reject), def) = + let (nary_async, nary_reply, reject, clean), def = new_nary_async_reply ts1 in ( blockE [ - letP (tupP [varP nary_async; varP nary_reply; varP reject]) def; + letP (tupP [varP nary_async; varP nary_reply; varP reject; varP clean]) 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 let ic_reject = - 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)) + let e = fresh_var "e" catch in + 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)) ] (varE nary_async) ).it | 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], _ ) -> + let tb, t_ret, t_fail, t_clean = match typ exp1 with + | Func(_,_, [tb], [t_ret; t_fail; t_clean], _ ) -> tb, t_typ (T.open_ [t] t_ret), - t_typ (T.open_ [t] t_fail) + t_typ (T.open_ [t] t_fail), + t_typ (T.open_ [t] t_clean) | t -> assert false in - 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 + let v_ret, v_fail, v_clean = fresh_var "v" t_ret, fresh_var "e" t_fail, fresh_var "c" t_clean in + ([v_ret; v_fail; v_clean] -->* callE (t_exp exp1) [t0] (List.map varE [v_ret; v_fail; v_clean] |> tupE)).it | PrimE (CallPrim typs, [exp1; exp2]) when is_awaitable_func exp1 -> let ts1,ts2 = match typ exp1 with - | T.Func (T.Shared _, T.Promises, tbs, ts1, ts2) -> + | Func (Shared _, Promises, tbs, ts1, ts2) -> List.map (fun t -> t_typ (T.open_ typs t)) ts1, List.map (fun t -> t_typ (T.open_ typs t)) ts2 - | _ -> assert(false) + | _ -> assert false in let exp1' = t_exp exp1 in let exp2' = t_exp exp2 in - let ((nary_async, nary_reply, reject), def) = + let (nary_async, nary_reply, reject, clean), def = new_nary_async_reply ts2 in (blockE ( - letP (tupP [varP nary_async; varP nary_reply; varP reject]) def :: + letP (tupP [varP nary_async; varP nary_reply; varP reject; varP clean]) 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)) ] + [expD (ic_callE v1 (seqE (List.map varE vs)) (varE nary_reply) (varE reject) (varE clean))] ) ) ) @@ -335,13 +344,13 @@ let transform prog = let exp1' = t_exp exp1 in let exp2' = t_exp exp2 in let exp3' = t_exp exp3 in - let ((nary_async, nary_reply, reject), def) = new_nary_async_reply [T.blob] in + let (nary_async, nary_reply, reject, clean), def = new_nary_async_reply [blob] in (blockE ( - letP (tupP [varP nary_async; varP nary_reply; varP reject]) def :: + letP (tupP [varP nary_async; varP nary_reply; varP reject; varP clean]) def :: let_eta exp1' (fun v1 -> let_eta exp2' (fun v2 -> let_eta exp3' (fun v3 -> - [ expD (ic_call_rawE v1 v2 v3 (varE nary_reply) (varE reject)) ] + [expD (ic_call_rawE v1 v2 v3 (varE nary_reply) (varE reject) (varE clean)) ] ) )) ) @@ -372,9 +381,9 @@ let transform prog = | FuncE (x, s, c, typbinds, args, ret_tys, exp) -> begin match s with - | T.Local -> + | Local -> FuncE (x, s, c, t_typ_binds typbinds, t_args args, List.map t_typ ret_tys, t_exp exp) - | T.Shared s' -> + | Shared s' -> begin match c, exp with | Promises, exp -> @@ -385,9 +394,9 @@ let transform prog = | PrimE (CPSAsync (Type.Fut, t0), [cps]) -> t_typ t0, cps | _ -> assert false in let t1, contT = match typ cps with - | Func (_,_, + | Func (_, _, [tb], - [Func(_, _, [], ts1, []) as contT; _], + [Func(_, _, [], ts1, []) as contT; _; _], []) -> (t_typ (T.seq (List.map (T.open_ [t0]) ts1)),t_typ (T.open_ [t0] contT)) | t -> assert false in @@ -395,10 +404,11 @@ let transform prog = let v = fresh_var "v" t1 in 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 - let exp' = callE (t_exp cps) [t0] (tupE [k;r]) in - FuncE (x, T.Shared s', Replies, typbinds', args', ret_tys, exp') + let e = fresh_var "e" catch in + e --> ic_rejectE (errorMessageE (varE e)) in + let cl = varE (var "@cleanup" clean_contT) in + let exp' = callE (t_exp cps) [t0] (tupE [k; r; cl]) in + FuncE (x, Shared s', Replies, typbinds', args', ret_tys, exp') (* oneway, always with `ignore(async _)` body *) | Returns, { it = BlockE ( @@ -416,21 +426,20 @@ let transform prog = let t1, contT = match typ cps with | Func (_, _, [tb], - [Func(_, _, [], ts1, []) as contT; _], + [Func(_, _, [], ts1, []) as contT; _; _], []) -> (t_typ (T.seq (List.map (T.open_ [t0]) ts1)),t_typ (T.open_ [t0] contT)) - | t -> assert false in + | _ -> assert false in let k = let v = fresh_var "v" t1 in v --> tupE [] in (* discard return *) let r = - let e = fresh_var "e" T.catch in - [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, _ -> - assert false - | Replies,_ -> assert false + let e = fresh_var "e" catch in + e --> tupE [] in + let cl = varE (var "@cleanup" clean_contT) in + let exp' = callE (t_exp cps) [t0] (tupE [k; r; cl]) in + FuncE (x, Shared s', Returns, typbinds', args', ret_tys, exp') + | (Returns | Replies), _ -> assert false end end | ActorE (ds, fs, {meta; preupgrade; postupgrade; heartbeat; timer; inspect}, typ) -> diff --git a/src/ir_passes/await.ml b/src/ir_passes/await.ml index 3cf213b2b2e..a6cff58cafe 100644 --- a/src/ir_passes/await.ml +++ b/src/ir_passes/await.ml @@ -12,6 +12,8 @@ let fresh_cont typ ans_typ = fresh_var "k" (contT typ ans_typ) let fresh_err_cont ans_typ = fresh_var "r" (err_contT ans_typ) +let fresh_bail_cont ans_typ = fresh_var "b" bail_contT + (* continuations, syntactic and meta-level *) type kont = ContVar of var @@ -20,7 +22,7 @@ type kont = ContVar of var let meta typ exp = let expanded = ref false in let exp v = - assert (not(!expanded)); + assert (not !expanded); expanded := true; exp v in @@ -37,8 +39,20 @@ let letcont k scope = blockE [funcD k' v e] (* at this point, I'm really worried about variable capture *) (scope k') -(* Named labels for break, special labels for return and throw *) -type label = Return | Throw | Named of string +(* pre-compose a continuation with a call to a `finally`-thunk *) +let precont k vthunk = + let finally e = blockE [expD (varE vthunk -*- unitE ())] e in + match k with + | ContVar k' -> + let typ = match typ_of_var k' with + | T.(Func (Local, Returns, [], ts1, _)) -> T.seq ts1 + | _ -> assert false in + MetaCont (typ, fun v -> finally (varE k' -*- varE v)) + | MetaCont (typ, cont) -> + MetaCont (typ, fun v -> finally (cont v)) + +(* Named labels for break, special labels for return, throw and cleanup *) +type label = Return | Throw | Cleanup | Named of string let ( -@- ) k exp2 = match k with @@ -68,12 +82,14 @@ let rec t_async context exp = (* add the implicit return label *) let k_ret = fresh_cont (typ exp1) T.unit in let k_fail = fresh_err_cont T.unit in + let k_clean = fresh_bail_cont T.unit in let context' = - LabelEnv.add Return (Cont (ContVar k_ret)) - (LabelEnv.add Throw (Cont (ContVar k_fail)) LabelEnv.empty) + LabelEnv.add Cleanup (Cont (ContVar k_clean)) + (LabelEnv.add Return (Cont (ContVar k_ret)) + (LabelEnv.singleton Throw (Cont (ContVar k_fail)))) in cps_asyncE s typ1 (typ exp1) - (forall [tb] ([k_ret; k_fail] -->* + (forall [tb] ([k_ret; k_fail; k_clean] -->* (c_exp context' exp1 (ContVar k_ret)))) | _ -> assert false @@ -100,9 +116,9 @@ and t_exp' context exp = SwitchE (t_exp context exp1, cases') | LoopE exp1 -> LoopE (t_exp context exp1) - | LabelE (id, _typ, exp1) -> + | LabelE (id, typ, exp1) -> let context' = LabelEnv.add (Named id) Label context in - LabelE (id, _typ, t_exp context' exp1) + LabelE (id, typ, t_exp context' exp1) | PrimE (BreakPrim id, [exp1]) -> begin match LabelEnv.find_opt (Named id) context with @@ -152,7 +168,7 @@ and t_exp' context exp = | FuncE (x, s, c, typbinds, pat, typs, exp1) -> assert (not (T.is_local_async_func (typ exp))); assert (not (T.is_shared_func (typ exp))); - let context' = LabelEnv.add Return Label LabelEnv.empty in + let context' = LabelEnv.singleton Return Label in FuncE (x, s, c, typbinds, pat, typs, t_exp context' exp1) | ActorE (ds, ids, { meta; preupgrade; postupgrade; heartbeat; timer; inspect}, t) -> ActorE (t_decs context ds, ids, @@ -324,29 +340,44 @@ and c_exp' context exp k = at = exp.at; note = Note.{ exp.note with typ = typ' } })) end) - | TryE (exp1, cases) -> + | TryE (exp1, cases, finally_opt) -> + let pre k = + match finally_opt with + | Some (id2, typ2) -> precont k (var id2 typ2) + | None -> k in + let pre' = function + | Cont k -> Cont (pre k) + | Label -> assert false in + (* All control-flow out must pass through the potential `finally` thunk *) + let context = LabelEnv.map pre' context in + (* assert that a context (top-level or async) has set up a `Cleanup` cont *) + assert (LabelEnv.find_opt Cleanup context <> None); (* TODO: do we need to reify f? *) let f = match LabelEnv.find Throw context with Cont f -> f | _ -> assert false in letcont f (fun f -> - letcont k (fun k -> + letcont (pre k) (fun k -> match eff exp1 with | T.Triv -> - varE k -*- (t_exp context exp1) + varE k -*- t_exp context exp1 + | T.Await when cases = [] -> + c_exp context exp1 (ContVar k) | T.Await -> - let error = fresh_var "v" T.catch in + let error = fresh_var "v" T.catch in + let rethrow = { it = { pat = varP error; exp = varE f -*- varE error }; + at = no_region; + note = () + } in + let omit_rethrow = List.exists (fun {it = {pat; exp}; _} -> Ir_utils.is_irrefutable pat) cases in let cases' = List.map - (fun {it = {pat;exp}; at; note} -> + (fun {it = { pat; exp }; at; note} -> let exp' = match eff exp with - | T.Triv -> varE k -*- (t_exp context exp) + | T.Triv -> varE k -*- t_exp context exp | T.Await -> c_exp context exp (ContVar k) in - { it = {pat;exp = exp' }; at; note }) + { it = { pat; exp = exp' }; at; note }) cases - @ [{ it = {pat = varP error; exp = varE f -*- varE error}; - at = no_region; - note = () - }] in + @ if omit_rethrow then [] else [rethrow] in let throw = fresh_err_cont (answerT (typ_of_var k)) in let context' = LabelEnv.add Throw (Cont (ContVar throw)) context in blockE @@ -370,22 +401,19 @@ and c_exp' context exp k = begin match LabelEnv.find_opt (Named id) context with | Some (Cont k') -> c_exp context exp1 k' - | Some Label -> assert false - | None -> assert false + | _ -> assert false end | PrimE (RetPrim, [exp1]) -> begin match LabelEnv.find_opt Return context with | Some (Cont k') -> c_exp context exp1 k' - | Some Label -> assert false - | None -> assert false + | _ -> assert false end | PrimE (ThrowPrim, [exp1]) -> begin match LabelEnv.find_opt Throw context with | Some (Cont k') -> c_exp context exp1 k' - | Some Label - | None -> assert false + | _ -> assert false end | AsyncE (T.Cmp, tb, exp1, typ1) -> assert false (* must have effect T.Triv, handled by first case *) @@ -393,18 +421,19 @@ and c_exp' context exp k = (* add the implicit return label *) let k_ret = fresh_cont (typ exp1) T.unit in let k_fail = fresh_err_cont T.unit in + let k_clean = fresh_bail_cont T.unit in let context' = - LabelEnv.add Return (Cont (ContVar k_ret)) - (LabelEnv.add Throw (Cont (ContVar k_fail)) LabelEnv.empty) + LabelEnv.add Cleanup (Cont (ContVar k_clean)) + (LabelEnv.add Return (Cont (ContVar k_ret)) + (LabelEnv.singleton Throw (Cont (ContVar k_fail)))) in let r = match LabelEnv.find_opt Throw context with | Some (Cont r) -> r - | Some Label - | None -> assert false + | _ -> assert false in let cps_async = cps_asyncE T.Fut typ1 (typ exp1) - (forall [tb] ([k_ret; k_fail] -->* + (forall [tb] ([k_ret; k_fail; k_clean] -->* (c_exp context' exp1 (ContVar k_ret)))) in let k' = meta (typ cps_async) (fun v -> @@ -416,19 +445,23 @@ and c_exp' context exp k = | PrimE (AwaitPrim s, [exp1]) -> let r = match LabelEnv.find_opt Throw context with | Some (Cont r) -> r - | Some Label - | None -> assert false + | _ -> assert false in + let b = match LabelEnv.find_opt Cleanup context with + | Some (Cont r) -> r + | _ -> assert false + in + letcont b (fun b -> letcont r (fun r -> letcont k (fun k -> - let kr = tupE [varE k; varE r] in + let krb = List.map varE [k; r; b] |> tupE in match eff exp1 with | T.Triv -> - cps_awaitE s (typ_of_var k) (t_exp context exp1) kr + cps_awaitE s (typ_of_var k) (t_exp context exp1) krb | T.Await -> c_exp context exp1 - (meta (typ exp1) (fun v1 -> (cps_awaitE s (typ_of_var k) (varE v1) kr))) - )) + (meta (typ exp1) (fun v1 -> (cps_awaitE s (typ_of_var k) (varE v1) krb))) + ))) | DeclareE (id, typ, exp1) -> unary context k (fun v1 -> e (DeclareE (id, typ, varE v1))) exp1 | DefineE (id, mut, exp1) -> @@ -438,8 +471,7 @@ and c_exp' context exp k = | PrimE (p, exps) when is_async_call p exps -> let r = match LabelEnv.find_opt Throw context with | Some (Cont r) -> r - | Some Label - | None -> assert false + | _ -> assert false in let k' = meta (typ exp) (fun v -> @@ -590,7 +622,9 @@ and t_comp_unit context = function ProgU (t_decs context ds) | T.Await -> let throw = fresh_err_cont T.unit in - let context' = LabelEnv.add Throw (Cont (ContVar throw)) context in + let context' = + LabelEnv.add Cleanup (Cont (ContVar (var "@cleanup" bail_contT))) + (LabelEnv.add Throw (Cont (ContVar throw)) context) in let e = fresh_var "e" T.catch in ProgU [ funcD throw e (assertE (falseE ())); @@ -614,7 +648,9 @@ and t_ignore_throw context exp = exp | _ -> let throw = fresh_err_cont T.unit in - let context' = LabelEnv.add Throw (Cont (ContVar throw)) context in + let context' = + LabelEnv.add Cleanup (Cont (ContVar (var "@cleanup" bail_contT))) + (LabelEnv.add Throw (Cont (ContVar throw)) context) in let e = fresh_var "e" T.catch in { (blockE [ funcD throw e (tupE[]); diff --git a/src/ir_passes/const.ml b/src/ir_passes/const.ml index 063f088febb..80f8389a5a6 100644 --- a/src/ir_passes/const.ml +++ b/src/ir_passes/const.ml @@ -147,15 +147,21 @@ let rec exp lvl (env : env) e : Lbool.t = exp_ lvl env e2; exp_ lvl env e3; surely_false - | SelfCallE (_, e1, e2, e3) -> + | SelfCallE (_, e1, e2, e3, e4) -> exp_ NotTopLvl env e1; exp_ lvl env e2; exp_ lvl env e3; + exp_ lvl env e4; surely_false - | SwitchE (e1, cs) | TryE (e1, cs) -> + | SwitchE (e1, cs) | TryE (e1, cs, None) -> exp_ lvl env e1; List.iter (case_ lvl env) cs; surely_false + | TryE (e1, cs, Some (v, t)) -> + exp_ lvl env e1; + List.iter (case_ lvl env) cs; + exp_ lvl env Construct.(var v t |> varE); + surely_false | NewObjE _ -> (* mutable objects *) surely_false | ActorE (ds, fs, {meta; preupgrade; postupgrade; heartbeat; timer; inspect}, _typ) -> diff --git a/src/ir_passes/eq.ml b/src/ir_passes/eq.ml index 92eb02988f9..fe2c907e841 100644 --- a/src/ir_passes/eq.ml +++ b/src/ir_passes/eq.ml @@ -229,14 +229,14 @@ and t_exp' env = function cases in SwitchE (t_exp env exp1, cases') - | TryE (exp1, cases) -> + | TryE (exp1, cases, vt) -> let cases' = List.map (fun {it = {pat;exp}; at; note} -> {it = {pat = pat; exp = t_exp env exp}; at; note}) cases in - TryE (t_exp env exp1, cases') + TryE (t_exp env exp1, cases', vt) | LoopE exp1 -> LoopE (t_exp env exp1) | LabelE (id, typ, exp1) -> @@ -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) -> - SelfCallE (ts, t_exp env e1, t_exp env e2, t_exp env e3) + | SelfCallE (ts, e1, e2, e3, e4) -> + SelfCallE (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/erase_typ_field.ml b/src/ir_passes/erase_typ_field.ml index 3a999ebe0a9..69a6727c3bf 100644 --- a/src/ir_passes/erase_typ_field.ml +++ b/src/ir_passes/erase_typ_field.ml @@ -118,8 +118,8 @@ let transform prog = 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) - | TryE (exp1, cases) -> - TryE (t_exp exp1, List.map t_case cases) + | TryE (exp1, cases, vt) -> + TryE (t_exp exp1, List.map t_case cases, vt) | DeclareE (id, typ, exp1) -> DeclareE (id, t_typ typ, t_exp exp1) | DefineE (id, mut ,exp1) -> diff --git a/src/ir_passes/show.ml b/src/ir_passes/show.ml index 08f70ea5be8..379899ec0c3 100644 --- a/src/ir_passes/show.ml +++ b/src/ir_passes/show.ml @@ -271,14 +271,14 @@ and t_exp' env = function cases in SwitchE (t_exp env exp1, cases') - | TryE (exp1, cases) -> + | TryE (exp1, cases, vt) -> let cases' = List.map (fun {it = {pat;exp}; at; note} -> - {it = {pat = pat; exp = t_exp env exp}; at; note}) + {it = {pat; exp = t_exp env exp}; at; note}) cases in - TryE (t_exp env exp1, cases') + TryE (t_exp env exp1, cases', vt) | LoopE exp1 -> LoopE (t_exp env exp1) | LabelE (id, typ, exp1) -> @@ -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) -> - SelfCallE (ts, t_exp env e1, t_exp env e2, t_exp env e3) + | SelfCallE (ts, e1, e2, e3, e4) -> + SelfCallE (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 3734fc8409e..6c5e9dcad83 100644 --- a/src/ir_passes/tailcall.ml +++ b/src/ir_passes/tailcall.ml @@ -92,7 +92,7 @@ and assignEs vars exp : dec list = List.mapi (fun i v -> expD (assignE v (projE (varE v) i))) vars and exp' env e : exp' = match e.it with - | VarE _ | LitE _ -> e.it + | (VarE _ | LitE _) as it -> it | AssignE (e1, e2) -> AssignE (lexp env e1, exp env e2) | PrimE (CallPrim insts, [e1; e2]) -> begin match e1.it, env with @@ -106,7 +106,7 @@ and exp' env e : exp' = match e.it with | BlockE (ds, e) -> BlockE (block env ds e) | IfE (e1, e2, e3) -> IfE (exp env e1, tailexp env e2, tailexp env e3) | SwitchE (e, cs) -> SwitchE (exp env e, cases env cs) - | TryE (e, cs) -> TryE (exp env e, cases env cs) (* TBR *) + | TryE (e, cs, vt) -> TryE (exp env e, cases env cs, vt) (* TBR *) | LoopE e1 -> LoopE (exp env e1) | LabelE (i, t, e) -> let env1 = bind env i None in LabelE(i, t, exp env1 e) @@ -120,12 +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) -> + | SelfCallE (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 - SelfCallE (ts, exp1', exp2', exp3') + let exp4' = exp env exp4 in + SelfCallE (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) diff --git a/src/lang_utils/error_codes.ml b/src/lang_utils/error_codes.ml index 15158cb264a..e1d4c1ded73 100644 --- a/src/lang_utils/error_codes.ml +++ b/src/lang_utils/error_codes.ml @@ -40,7 +40,7 @@ let error_codes : (string * string option) list = "M0034", None; (* Shared constructor has non-shared parameter type *) "M0035", None; (* Invalid return type for shared function *) "M0036", None; (* Invalid return type for shared query function *) - "M0037", None; (* Misplaced async expression *) + "M0037", Some([%blob "lang_utils/error_codes/M0037.md"]); (* Misplaced async expression *) "M0038", None; (* Misplaced await *) "M0039", None; (* Misplaced try/throw/catch *) "M0040", None; (* Unknown primitive type *) diff --git a/src/lang_utils/error_codes/M0037.md b/src/lang_utils/error_codes/M0037.md new file mode 100644 index 00000000000..de24c3219f1 --- /dev/null +++ b/src/lang_utils/error_codes/M0037.md @@ -0,0 +1,19 @@ +# M0037 + +If you get this error then you are trying to message from a +block or expression that has no send capability, such as the +top level of an `actor`. + +You can also get this error when you are trying to message or +`throw` an error from the `finally` clause of a `try` block. + +`finally` clauses are generally used to clean up local state +in the event of messaging failures, and are especially invoked when +the processing of an `await` result traps. In this last-resort cleanup +only local manipulations are allowed to (e.g.) release locks and thus +prevent the canister from ending up in a stuck state. + +Should you encounter this error, so make sure that you move all messaging +code out of the `finally` block. In all other cases where send capability +is available, wrapping the indicated expression in an `async` can help. + diff --git a/src/lang_utils/error_codes/M0199.md b/src/lang_utils/error_codes/M0199.md index ede4eae7deb..340aff01eab 100644 --- a/src/lang_utils/error_codes/M0199.md +++ b/src/lang_utils/error_codes/M0199.md @@ -15,5 +15,3 @@ The `moc` compiler flag `--experimental-stable-memory ` flag controls the pro * n > 1: warning-less use of stable memory primitives (for legacy applications). I.e. if your application cannot easily be upgraded to use `Regions.mo` and still requires access to `ExperimentalStableMemory.mo`, you can opt-in to legacy support for `ExperimentalStableMemory.mo` using the `moc` compiler flag `--experimental-stable-memory 1`. - - diff --git a/src/lib/lib.ml b/src/lib/lib.ml index e4517cc22f3..6b0cd938ad9 100644 --- a/src/lib/lib.ml +++ b/src/lib/lib.ml @@ -1,3 +1,5 @@ +module StdList = List + module Format = struct let with_str_formatter f x = @@ -502,12 +504,11 @@ end module Option = struct - let get o x = - match o with - | Some y -> y - | None -> x + let get o x = Option.value o ~default:x + + let exists f o = Option.to_list o |> StdList.exists f - let map2 (f : 'a -> 'b -> 'c) (a : 'a option) (b : 'b option) = + let map2 f a b = match a, b with | Some a, Some b -> Some (f a b) | _ -> None diff --git a/src/lib/lib.mli b/src/lib/lib.mli index 778cf2acdab..795e35f1054 100644 --- a/src/lib/lib.mli +++ b/src/lib/lib.mli @@ -96,6 +96,7 @@ sig val (and+) : 'a option -> 'b option -> ('a * 'b) option end val get : 'a option -> 'a -> 'a + val exists : ('a -> bool) -> 'a option -> bool val map2 : ('a -> 'b -> 'c) -> 'a option -> 'b option -> 'c option end diff --git a/src/lowering/desugar.ml b/src/lowering/desugar.ml index f3ffa3cacd5..26cea6c91bd 100644 --- a/src/lowering/desugar.ml +++ b/src/lowering/desugar.ml @@ -216,7 +216,14 @@ and exp' at note = function | S.OldE e -> (oldE (exp e)).it | S.IfE (e1, e2, e3) -> I.IfE (exp e1, exp e2, exp e3) | S.SwitchE (e1, cs) -> I.SwitchE (exp e1, cases cs) - | S.TryE (e1, cs) -> I.TryE (exp e1, cases cs) + | S.TryE (e1, cs, None) -> I.TryE (exp e1, cases cs, None) + | S.TryE (e1, cs, Some e2) -> + let thunk = [] -->* exp e2 |> named "$cleanup" in + assert T.(is_func thunk.note.Note.typ); + let th = fresh_var "thunk" thunk.note.Note.typ in + (blockE + [ letD th thunk ] + { e1 with it = I.TryE (exp e1, cases cs, Some (id_of_var th, typ_of_var th)); note }).it | 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 @@ -776,11 +783,11 @@ and dec' at n = function } in I.LetD (varPat, fn) -and cases cs = List.map case cs +and cases cs = List.map (case (fun x -> x)) cs -and case c = phrase case' c +and case f c = phrase (case' f) c -and case' c = S.{ I.pat = pat c.pat; I.exp = exp c.exp } +and case' f c = S.{ I.pat = pat c.pat; I.exp = f (exp c.exp) } and pats ps = List.map pat ps diff --git a/src/mo_def/arrange.ml b/src/mo_def/arrange.ml index bd59ab545a0..b5a1500d74f 100644 --- a/src/mo_def/arrange.ml +++ b/src/mo_def/arrange.ml @@ -126,7 +126,8 @@ module Make (Cfg : Config) = struct | PrimE p -> "PrimE" $$ [Atom p] | ImportE (f, _fp) -> "ImportE" $$ [Atom f] | ThrowE e -> "ThrowE" $$ [exp e] - | TryE (e, cs) -> "TryE" $$ [exp e] @ List.map catch cs + | TryE (e, cs, None) -> "TryE" $$ [exp e] @ List.map catch cs + | TryE (e, cs, Some f)-> "TryE" $$ [exp e] @ List.map catch cs @ Atom ";" :: [exp f] | IgnoreE e -> "IgnoreE" $$ [exp e])) and exps es = List.map exp es diff --git a/src/mo_def/syntax.ml b/src/mo_def/syntax.ml index ab86ff75226..e61ac27b216 100644 --- a/src/mo_def/syntax.ml +++ b/src/mo_def/syntax.ml @@ -193,10 +193,9 @@ and exp' = | AnnotE of exp * typ (* type annotation *) | ImportE of (string * resolved_import ref) (* import statement *) | ThrowE of exp (* throw exception *) - | TryE of exp * case list (* catch exception *) + | TryE of exp * case list * exp option (* catch exception / finally *) | IgnoreE of exp (* ignore *) (* - | FinalE of exp * exp (* finally *) | AtomE of string (* atom *) *) diff --git a/src/mo_frontend/definedness.ml b/src/mo_frontend/definedness.ml index af8b6c99624..9255bff48c3 100644 --- a/src/mo_frontend/definedness.ml +++ b/src/mo_frontend/definedness.ml @@ -117,7 +117,8 @@ let rec exp msgs e : f = match e.it with | OldE e -> exp msgs e | IfE (e1, e2, e3) -> exps msgs [e1; e2; e3] | SwitchE (e, cs) -> exp msgs e ++ cases msgs cs - | TryE (e, cs) -> exp msgs e ++ cases msgs cs + | TryE (e, cs, None) -> exp msgs e ++ cases msgs cs + | TryE (e, cs, Some f)-> exps msgs [e; f] ++ cases msgs cs | WhileE (e1, e2) -> exps msgs [e1; e2] | LoopE (e1, None) -> exp msgs e1 | LoopE (e1, Some e2) -> exps msgs [e1; e2] diff --git a/src/mo_frontend/error_reporting.ml b/src/mo_frontend/error_reporting.ml index 78cf5e56ffe..6b2122d1dc1 100644 --- a/src/mo_frontend/error_reporting.ml +++ b/src/mo_frontend/error_reporting.ml @@ -20,6 +20,7 @@ let terminal2token (type a) (symbol : a terminal) : token = | T_TYPE -> TYPE | T_TRY -> TRY | T_THROW -> THROW + | T_FINALLY -> FINALLY | T_TEXT -> TEXT "..." | T_SWITCH -> SWITCH | T_SUBOP -> SUBOP diff --git a/src/mo_frontend/parser.mly b/src/mo_frontend/parser.mly index 5ceca1e9e6e..ebb331fd0cb 100644 --- a/src/mo_frontend/parser.mly +++ b/src/mo_frontend/parser.mly @@ -210,7 +210,7 @@ and objblock s ty dec_fields = %token LET VAR %token LPAR RPAR LBRACKET RBRACKET LCURLY RCURLY %token AWAIT AWAITSTAR ASYNC ASYNCSTAR BREAK CASE CATCH CONTINUE DO LABEL DEBUG -%token IF IGNORE IN ELSE SWITCH LOOP WHILE FOR RETURN TRY THROW WITH +%token IF IGNORE IN ELSE SWITCH LOOP WHILE FOR RETURN TRY THROW FINALLY WITH %token ARROW ASSIGN %token FUNC TYPE OBJECT ACTOR CLASS PUBLIC PRIVATE SHARED SYSTEM QUERY %token SEMICOLON SEMICOLON_EOL COMMA COLON SUB DOT QUEST BANG @@ -244,8 +244,8 @@ and objblock s ty dec_fields = %nonassoc IMPLIES (* see assertions.mly *) -%nonassoc RETURN_NO_ARG IF_NO_ELSE LOOP_NO_WHILE -%nonassoc ELSE WHILE +%nonassoc RETURN_NO_ARG IF_NO_ELSE LOOP_NO_WHILE TRY_CATCH_NO_FINALLY +%nonassoc ELSE WHILE FINALLY %left COLON %left PIPE @@ -707,8 +707,12 @@ exp_un(B) : { IfE(b, e1, TupE([]) @? at $sloc) @? at $sloc } | IF b=exp_nullary(ob) e1=exp_nest ELSE e2=exp_nest { IfE(b, e1, e2) @? at $sloc } - | TRY e1=exp_nest c=catch - { TryE(e1, [c]) @? at $sloc } + | TRY e1=exp_nest c=catch %prec TRY_CATCH_NO_FINALLY + { TryE(e1, [c], None) @? at $sloc } + | TRY e1=exp_nest c=catch FINALLY e2=exp_nest + { TryE(e1, [c], Some e2) @? at $sloc } + | TRY e1=exp_nest FINALLY e2=exp_nest + { TryE(e1, [], Some e2) @? at $sloc } (* TODO: enable multi-branch TRY (already supported by compiler) | TRY e=exp_nest LCURLY cs=seplist(case, semicolon) RCURLY { TryE(e, cs) @? at $sloc } diff --git a/src/mo_frontend/printers.ml b/src/mo_frontend/printers.ml index c0b9e5c0a3a..7105e3e7cc7 100644 --- a/src/mo_frontend/printers.ml +++ b/src/mo_frontend/printers.ml @@ -26,6 +26,7 @@ let string_of_symbol = function | X (T T_TYPE) -> "type" | X (T T_TRY) -> "try" | X (T T_THROW) -> "throw" + | X (T T_FINALLY) -> "finally" | X (T T_TEXT) -> "" | X (T T_SWITCH) -> "switch" | X (T T_SUBOP) -> unop "-" diff --git a/src/mo_frontend/source_lexer.mll b/src/mo_frontend/source_lexer.mll index ad9de260ff0..2e527822c79 100644 --- a/src/mo_frontend/source_lexer.mll +++ b/src/mo_frontend/source_lexer.mll @@ -214,6 +214,7 @@ rule token mode = parse | "do" { DO } | "else" { ELSE } | "false" { BOOL false } + | "finally" { FINALLY } | "flexible" { FLEXIBLE } | "for" { FOR } | "from_candid" { FROM_CANDID } diff --git a/src/mo_frontend/source_token.ml b/src/mo_frontend/source_token.ml index 1d385c23288..b49a7071967 100644 --- a/src/mo_frontend/source_token.ml +++ b/src/mo_frontend/source_token.ml @@ -22,6 +22,7 @@ type token = | LABEL | DEBUG | DO + | FINALLY | FLEXIBLE | IF | IGNORE @@ -163,6 +164,7 @@ let to_parser_token : | RETURN -> Ok Parser.RETURN | TRY -> Ok Parser.TRY | THROW -> Ok Parser.THROW + | FINALLY -> Ok Parser.FINALLY | WITH -> Ok Parser.WITH | ARROW -> Ok Parser.ARROW | ASSIGN -> Ok Parser.ASSIGN @@ -291,6 +293,7 @@ let string_of_parser_token = function | Parser.RETURN -> "RETURN" | Parser.TRY -> "TRY" | Parser.THROW -> "THROW" + | Parser.FINALLY -> "FINALLY" | Parser.WITH -> "WITH" | Parser.ARROW -> "ARROW" | Parser.ASSIGN -> "ASSIGN" diff --git a/src/mo_frontend/traversals.ml b/src/mo_frontend/traversals.ml index db769cefbd0..aba776444b3 100644 --- a/src/mo_frontend/traversals.ml +++ b/src/mo_frontend/traversals.ml @@ -60,8 +60,8 @@ let rec over_exp (f : exp -> exp) (exp : exp) : exp = match exp.it with f { exp with it = ObjE (List.map (over_exp f) bases, List.map (over_exp_field f) efs) } | IfE (exp1, exp2, exp3) -> f { exp with it = IfE(over_exp f exp1, over_exp f exp2, over_exp f exp3) } - | TryE (exp1, cases) -> - f { exp with it = TryE (over_exp f exp1, List.map (over_case f) cases) } + | TryE (exp1, cases, exp2_opt) -> + f { exp with it = TryE (over_exp f exp1, List.map (over_case f) cases, Option.map (over_exp f) exp2_opt) } | SwitchE (exp1, cases) -> f { exp with it = SwitchE (over_exp f exp1, List.map (over_case f) cases) } | FuncE (name, sort_pat, typ_binds, pat, typ_opt, sugar, exp1) -> diff --git a/src/mo_frontend/typing.ml b/src/mo_frontend/typing.ml index 7678e24ecc2..516d6432027 100644 --- a/src/mo_frontend/typing.ml +++ b/src/mo_frontend/typing.ml @@ -961,9 +961,12 @@ let rec is_explicit_exp e = | ObjBlockE (_, _, dfs) -> List.for_all (fun (df : dec_field) -> is_explicit_dec df.it.dec) dfs | ArrayE (_, es) -> List.exists is_explicit_exp es - | SwitchE (e1, cs) | TryE (e1, cs) -> + | SwitchE (e1, cs) -> is_explicit_exp e1 && List.exists (fun (c : case) -> is_explicit_exp c.it.exp) cs + | TryE (e1, cs, _) -> + is_explicit_exp e1 && + (cs = [] || List.exists (fun (c : case) -> is_explicit_exp c.it.exp) cs) | BlockE ds -> List.for_all is_explicit_dec ds | FuncE (_, _, _, p, t_opt, _, _) -> is_explicit_pat p && t_opt <> None | LoopE (_, e_opt) -> e_opt <> None @@ -1531,12 +1534,14 @@ and infer_exp'' env exp : T.typ = if not env.pre then coverage_cases "switch" env cases t1 exp.at; t - | TryE (exp1, cases) -> + | TryE (exp1, cases, exp2_opt) -> let t1 = infer_exp env exp1 in let t2 = infer_cases env T.catch T.Non cases in if not env.pre then begin check_ErrorCap env "try" exp.at; - coverage_cases "try handler" env cases T.catch exp.at + if cases <> [] then + coverage_cases "try handler" env cases T.catch exp.at; + Option.iter (check_exp_strong { env with async = C.NullCap; rets = None; labs = T.Env.empty } T.unit) exp2_opt end; T.lub t1 t2 | WhileE (exp1, exp2) -> @@ -1833,11 +1838,14 @@ and check_exp' env0 t exp : T.typ = check_cases env t1 t cases; coverage_cases "switch" env cases t1 exp.at; t - | TryE (exp1, cases), _ -> + | TryE (exp1, cases, exp2_opt), _ -> check_ErrorCap env "try" exp.at; check_exp env t exp1; check_cases env T.catch t cases; - coverage_cases "try handler" env cases T.catch exp.at; + if cases <> [] + then coverage_cases "try handler" env cases T.catch exp.at; + if not env.pre then + Option.iter (check_exp_strong { env with async = C.NullCap; rets = None; labs = T.Env.empty; } T.unit) exp2_opt; t (* TODO: allow shared with one scope par *) | FuncE (_, shared_pat, [], pat, typ_opt, _sugar, exp), T.Func (s, c, [], ts1, ts2) -> diff --git a/src/mo_interpreter/interpret.ml b/src/mo_interpreter/interpret.ml index 8537e4e74fe..cd02a23b882 100644 --- a/src/mo_interpreter/interpret.ml +++ b/src/mo_interpreter/interpret.ml @@ -511,7 +511,7 @@ and interpret_exp_mut env exp (k : V.value V.cont) = | V.Blob aid when T.sub exp1.note.note_typ (T.Obj (T.Actor, [])) -> begin match V.Env.find_opt aid !(env.actor_env) with (* not quite correct: On the platform, you can invoke and get a reject *) - | None -> trap exp.at "Unkown actor \"%s\"" aid + | None -> trap exp.at "Unknown actor \"%s\"" aid | Some actor_value -> let fs = V.as_obj actor_value in match V.Env.find_opt id.it fs with @@ -620,10 +620,17 @@ and interpret_exp_mut env exp (k : V.value V.cont) = interpret_exp env exp1 (fun v1 -> interpret_cases env cases exp.at v1 k ) - | TryE (exp1, cases) -> - let k' = fun v1 -> interpret_catches env cases exp.at v1 k in - let env' = { env with throws = Some k' } in - interpret_exp env' exp1 k + | TryE (exp1, cases, exp2_opt) -> + let k, env = match exp2_opt with + | None -> k, env + | Some exp2 -> + let pre k v = interpret_exp env exp2 (fun v2 -> V.as_unit v2; k v) in + pre k, + { env with rets = Option.map pre env.rets + ; labs = V.Env.map pre env.labs + ; throws = Option.map pre env.throws } in + let k' v1 = interpret_catches env cases exp.at v1 k in + interpret_exp { env with throws = Some k' } exp1 k | WhileE (exp1, exp2) -> let k_continue = fun v -> V.as_unit v; interpret_exp env exp k in interpret_exp env exp1 (fun v1 -> diff --git a/src/prelude/internals.mo b/src/prelude/internals.mo index 596a2fa2c2e..47212cd0d04 100644 --- a/src/prelude/internals.mo +++ b/src/prelude/internals.mo @@ -284,8 +284,10 @@ func @equal_array(eq : (T, T) -> Bool, a : [T], b : [T]) : Bool { return true; }; +type @CleanCont = () -> (); +type @BailCont = @CleanCont; type @Cont = T -> () ; -type @Async = (@Cont,@Cont) -> { +type @Async = (@Cont, @Cont, @BailCont) -> { #suspend; #schedule : () -> (); }; @@ -307,7 +309,11 @@ func @getSystemRefund() : @Refund { return (prim "cyclesRefunded" : () -> Nat) (); }; -func @new_async() : (@Async, @Cont, @Cont) { +// trivial cleanup action +func @cleanup() { +}; + +func @new_async() : (@Async, @Cont, @Cont, @CleanCont) { let w_null = func(r : @Refund, t : T) { }; let r_null = func(_ : Error) {}; var result : ?(@Result) = null; @@ -342,10 +348,17 @@ func @new_async() : (@Async, @Cont, @Cont) { }; }; - func enqueue(k : @Cont, r : @Cont) : { + var cleanup : @BailCont = @cleanup; + + func clean() { + cleanup(); + }; + + func enqueue(k : @Cont, r : @Cont, b : @BailCont) : { #suspend; #schedule : () -> (); } { + cleanup := b; switch result { case null { let ws_ = ws; @@ -373,7 +386,7 @@ func @new_async() : (@Async, @Cont, @Cont) { }; }; - (enqueue, fulfill, fail) + (enqueue, fulfill, fail, clean) }; // Subset of IC management canister interface required for our use diff --git a/src/viper/traversals.ml b/src/viper/traversals.ml index a21c99178a1..c5cf7933ea4 100644 --- a/src/viper/traversals.ml +++ b/src/viper/traversals.ml @@ -51,7 +51,7 @@ let rec over_exp (v : visitor) (exp : exp) : exp = | ObjBlockE (x, t, dfs) -> { exp with it = ObjBlockE (x, Option.map (over_typ v) t, List.map (over_dec_field v) dfs) } | ObjE (bases, efs) -> { exp with it = ObjE (List.map (over_exp v) bases, List.map (over_exp_field v) efs) } | IfE (exp1, exp2, exp3) -> { exp with it = IfE(over_exp v exp1, over_exp v exp2, over_exp v exp3) } - | TryE (exp1, cases) -> { exp with it = TryE (over_exp v exp1, List.map (over_case v) cases) } + | TryE (exp1, cases, exp2) -> { exp with it = TryE (over_exp v exp1, List.map (over_case v) cases, Option.map (over_exp v) exp2) } | SwitchE (exp1, cases) -> { exp with it = SwitchE (over_exp v exp1, List.map (over_case v) cases) } | FuncE (name, sort_pat, typ_binds, pat, typ_opt, sugar, exp1) -> { exp with it = FuncE (name, sort_pat, typ_binds, over_pat v pat, Option.map (over_typ v) typ_opt, sugar, over_exp v exp1) } | IgnoreE exp1 -> { exp with it = IgnoreE (over_exp v exp1)}) diff --git a/test/fail/ok/try-finally.tc.ok b/test/fail/ok/try-finally.tc.ok new file mode 100644 index 00000000000..9615e26ab19 --- /dev/null +++ b/test/fail/ok/try-finally.tc.ok @@ -0,0 +1,9 @@ +try-finally.mo:10.26-10.29: type error [M0047], send capability required, but not available + (need an enclosing async expression or function body) +try-finally.mo:16.19-16.37: type error [M0039], misplaced throw +try-finally.mo:22.19-22.21: type error [M0050], literal of type + Nat +does not have expected type + () +try-finally.mo:28.19-28.25: type error [M0085], misplaced return +try-finally.mo:34.25-34.28: type error [M0083], unbound label out diff --git a/test/fail/ok/try-finally.tc.ret.ok b/test/fail/ok/try-finally.tc.ret.ok new file mode 100644 index 00000000000..69becfa16f9 --- /dev/null +++ b/test/fail/ok/try-finally.tc.ret.ok @@ -0,0 +1 @@ +Return code 1 diff --git a/test/fail/try-finally.mo b/test/fail/try-finally.mo new file mode 100644 index 00000000000..8ecd9b47e96 --- /dev/null +++ b/test/fail/try-finally.mo @@ -0,0 +1,37 @@ +import { error } = "mo:⛔"; + +actor A { + func m() : async () { + }; + + func _t0() : async () { + try { await m() } + catch _ {} + finally { ignore m() } // BAD: no effects allowed! + }; + + func _t1() : async () { + try { await m() } + catch _ {} + finally { throw error "Nope" } // BAD: has effect. + }; + + func _t2() : async () { + try { await m() } + catch _ {} + finally { 42 } // BAD: should return unit. + }; + + func _t3r() : async () { + try { await m() } + catch _ {} + finally { return } // BAD: no outward edges allowed! + }; + + func _t3l() : async () { + label out try { await m() } + catch _ {} + finally { break out } // BAD: no outward edges allowed! + }; + +} diff --git a/test/run-drun/ok/try-finally-bug.tc.ok b/test/run-drun/ok/try-finally-bug.tc.ok new file mode 100644 index 00000000000..7b395a1134e --- /dev/null +++ b/test/run-drun/ok/try-finally-bug.tc.ok @@ -0,0 +1 @@ +try-finally-bug.mo:8.18-8.26: type error [M0037], misplaced async expression; try enclosing in an async function diff --git a/test/run-drun/ok/try-finally-bug.tc.ret.ok b/test/run-drun/ok/try-finally-bug.tc.ret.ok new file mode 100644 index 00000000000..69becfa16f9 --- /dev/null +++ b/test/run-drun/ok/try-finally-bug.tc.ret.ok @@ -0,0 +1 @@ +Return code 1 diff --git a/test/run-drun/ok/try-finally.drun-run.ok b/test/run-drun/ok/try-finally.drun-run.ok new file mode 100644 index 00000000000..38c1da2134d --- /dev/null +++ b/test/run-drun/ok/try-finally.drun-run.ok @@ -0,0 +1,110 @@ +ingress Completed: Reply: 0x4449444c016c01b3c4b1f204680100010a00000000000000000101 +ingress Completed: Reply: 0x4449444c0000 +debug.print: INt +debug.print: OUTt +debug.print: INl +debug.print: OUTl +debug.print: INe +debug.print: OUTe +debug.print: BEFORE1 +debug.print: IN1 +debug.print: IN1Inner +debug.print: OUT1Inner +debug.print: CAUGHT1 +debug.print: OUT1 +debug.print: AFTER1 +debug.print: BEFORE1t +debug.print: IN1t +debug.print: IN1tInner +debug.print: CAUGHT1tInner +debug.print: OUT1tInner +debug.print: CAUGHT1t +debug.print: OUT1t +debug.print: AFTER1t +debug.print: IN2 +debug.print: CAUGHT2 +debug.print: OUT2 +debug.print: IN2r +debug.print: CAUGHT2r +debug.print: OUT2r +debug.print: IN2b +debug.print: CAUGHT2b +debug.print: OUT2b +debug.print: AFTER2b +debug.print: IN2i +debug.print: CAUGHT2i +debug.print: OUT2i +debug.print: IN3 +debug.print: OUT3 +debug.print: IN4 +debug.print: OUT4 +debug.print: BEFORE5 +debug.print: IN5 +debug.print: OUT5 +debug.print: AFTER5 +debug.print: BEFORE6 +debug.print: IN6 +debug.print: InnerIN6 +debug.print: InnerLIVE6 +debug.print: InnerOUT6 +debug.print: OUT6 +debug.print: AFTER6 +debug.print: IN8 +debug.print: CAUGHT8 +debug.print: OUT8 +debug.print: IN8i +debug.print: CAUGHT8i +debug.print: OUT8i +debug.print: IN9 +debug.print: OUT9 +debug.print: From the other side +debug.print: IN +debug.print: OUT +debug.print: INr +debug.print: OUTr +debug.print: INd +debug.print: AGAINd +debug.print: OUTd +debug.print: IN2t +debug.print: CAUGHT2t +debug.print: OUT2t +debug.print: BEFORE6c +debug.print: IN6c +debug.print: InnerIN6c +debug.print: InnerLIVE6c +debug.print: InnerCATCH6c +debug.print: InnerOUT6c +debug.print: OUT6c +debug.print: BEFORE6t +debug.print: IN6t +debug.print: InnerIN6t +debug.print: InnerLIVE6t +debug.print: InnerOUT6t +debug.print: OUT6t +debug.print: BEFORE6d +debug.print: IN6d +debug.print: InnerIN6d +debug.print: InnerLIVE6d +debug.print: InnerLIVESTILL6d +debug.print: InnerOUT6d +debug.print: OUT6d +debug.print: IN8t +debug.print: InnerIN8t +debug.print: OUT8t +debug.print: OTHER SIDE +debug.print: OTHER SIDE: CLEANING UP +debug.print: IC0503: Canister rwlgt-iiaaa-aaaaa-aaaaa-cai trapped explicitly: assertion failed at try-finally.mo:324.17-324.29 +debug.print: IC0503: Canister rwlgt-iiaaa-aaaaa-aaaaa-cai trapped explicitly: assertion failed at try-finally.mo:330.25-330.41 +debug.print: OUTER CAUGHT: foo +debug.print: BEFORE7 +debug.print: IN7 +debug.print: InnerIN7 +debug.print: InnerLIVE7 +debug.print: InnerLIVESTILL7 +debug.print: InnerOUT7 +debug.print: OUT7 +debug.print: It's over +ingress Err: IC0503: Canister rwlgt-iiaaa-aaaaa-aaaaa-cai trapped explicitly: assertion failed at try-finally.mo:238.17-238.29 +debug.print: go2 +debug.print: It's so over +ingress Err: IC0503: Canister rwlgt-iiaaa-aaaaa-aaaaa-cai trapped explicitly: assertion failed at try-finally.mo:350.13-350.25 diff --git a/test/run-drun/ok/try-finally.run-ir.ok b/test/run-drun/ok/try-finally.run-ir.ok new file mode 100644 index 00000000000..e90b67e7dc4 --- /dev/null +++ b/test/run-drun/ok/try-finally.run-ir.ok @@ -0,0 +1,60 @@ +INt +OUTt +INl +OUTl +INe +OUTe +BEFORE1 +IN1 +IN1Inner +OUT1Inner +CAUGHT1 +OUT1 +AFTER1 +BEFORE1t +IN1t +IN1tInner +CAUGHT1tInner +OUT1tInner +CAUGHT1t +OUT1t +AFTER1t +IN2 +CAUGHT2 +OUT2 +IN2r +CAUGHT2r +OUT2r +IN2b +CAUGHT2b +OUT2b +AFTER2b +IN2i +CAUGHT2i +OUT2i +IN3 +OUT3 +IN4 +OUT4 +BEFORE5 +IN5 +OUT5 +AFTER5 +BEFORE6 +IN6 +InnerIN6 +InnerLIVE6 +InnerOUT6 +OUT6 +AFTER6 +IN8 +CAUGHT8 +OUT8 +IN8i +CAUGHT8i +OUT8i +IN9 +OUT9 +From the other side +IN +try-finally.mo:11.43-11.55: execution error, assertion failure diff --git a/test/run-drun/ok/try-finally.run-low.ok b/test/run-drun/ok/try-finally.run-low.ok new file mode 100644 index 00000000000..e90b67e7dc4 --- /dev/null +++ b/test/run-drun/ok/try-finally.run-low.ok @@ -0,0 +1,60 @@ +INt +OUTt +INl +OUTl +INe +OUTe +BEFORE1 +IN1 +IN1Inner +OUT1Inner +CAUGHT1 +OUT1 +AFTER1 +BEFORE1t +IN1t +IN1tInner +CAUGHT1tInner +OUT1tInner +CAUGHT1t +OUT1t +AFTER1t +IN2 +CAUGHT2 +OUT2 +IN2r +CAUGHT2r +OUT2r +IN2b +CAUGHT2b +OUT2b +AFTER2b +IN2i +CAUGHT2i +OUT2i +IN3 +OUT3 +IN4 +OUT4 +BEFORE5 +IN5 +OUT5 +AFTER5 +BEFORE6 +IN6 +InnerIN6 +InnerLIVE6 +InnerOUT6 +OUT6 +AFTER6 +IN8 +CAUGHT8 +OUT8 +IN8i +CAUGHT8i +OUT8i +IN9 +OUT9 +From the other side +IN +try-finally.mo:11.43-11.55: execution error, assertion failure diff --git a/test/run-drun/ok/try-finally.run.ok b/test/run-drun/ok/try-finally.run.ok new file mode 100644 index 00000000000..e90b67e7dc4 --- /dev/null +++ b/test/run-drun/ok/try-finally.run.ok @@ -0,0 +1,60 @@ +INt +OUTt +INl +OUTl +INe +OUTe +BEFORE1 +IN1 +IN1Inner +OUT1Inner +CAUGHT1 +OUT1 +AFTER1 +BEFORE1t +IN1t +IN1tInner +CAUGHT1tInner +OUT1tInner +CAUGHT1t +OUT1t +AFTER1t +IN2 +CAUGHT2 +OUT2 +IN2r +CAUGHT2r +OUT2r +IN2b +CAUGHT2b +OUT2b +AFTER2b +IN2i +CAUGHT2i +OUT2i +IN3 +OUT3 +IN4 +OUT4 +BEFORE5 +IN5 +OUT5 +AFTER5 +BEFORE6 +IN6 +InnerIN6 +InnerLIVE6 +InnerOUT6 +OUT6 +AFTER6 +IN8 +CAUGHT8 +OUT8 +IN8i +CAUGHT8i +OUT8i +IN9 +OUT9 +From the other side +IN +try-finally.mo:11.43-11.55: execution error, assertion failure diff --git a/test/run-drun/try-finally-bug.mo b/test/run-drun/try-finally-bug.mo new file mode 100644 index 00000000000..ccdbbc508b4 --- /dev/null +++ b/test/run-drun/try-finally-bug.mo @@ -0,0 +1,21 @@ +import { debugPrint; error; call_raw; principalOfActor } = "mo:⛔"; + +actor A { + + func t0() : async () { + let () = try { } + finally { + ignore async {}; + }; + }; + + public func go() : async () { + await t0(); + }; + +}; + +//SKIP ic-ref-run + +A.go(); //OR-CALL ingress go "DIDL\x00\x00" + diff --git a/test/run-drun/try-finally.mo b/test/run-drun/try-finally.mo new file mode 100644 index 00000000000..c36012d3f49 --- /dev/null +++ b/test/run-drun/try-finally.mo @@ -0,0 +1,359 @@ +import { debugPrint; error; errorMessage; call_raw; principalOfActor } = "mo:⛔"; + +actor A { + func m() : async () { + }; + + public func raw() : async () { + }; + + func t0() : async () { + try { debugPrint "IN"; await m(); assert false } + finally { debugPrint "OUT" }; + }; + + func t0t() : async () { + try { debugPrint "INt" } + finally { debugPrint "OUTt" }; + }; + + func t0l() : async () { + label out try { debugPrint "INl"; break out } + finally { debugPrint "OUTl" }; + }; + + func t0e() : async () { + label out try { debugPrint "INe"; return () } + finally { debugPrint "OUTe" }; + }; + + func t0r() : async () { + let p = principalOfActor A; + try { debugPrint "INr"; ignore await call_raw(p, "raw", to_candid()); assert false } + finally { debugPrint "OUTr" }; + }; + + func t0d() : async () { + try { debugPrint "INd"; let fut = m(); await fut; debugPrint "AGAINd"; await fut; assert false } + finally { debugPrint "OUTd" }; + }; + + func t1() : async () { + debugPrint "BEFORE1"; + try { + debugPrint "IN1"; + try { + debugPrint "IN1Inner"; + throw error "IN1Inner"; + } + finally { debugPrint "OUT1Inner" }; + } + catch _ { debugPrint "CAUGHT1" } + finally { debugPrint "OUT1" }; + debugPrint "AFTER1" + }; + + func t1t() : async () { + debugPrint "BEFORE1t"; + try { + debugPrint "IN1t"; + try { + debugPrint "IN1tInner"; + throw error "IN1tInner"; + } + catch e { debugPrint "CAUGHT1tInner"; throw e } + finally { debugPrint "OUT1tInner" }; + } + catch _ { debugPrint "CAUGHT1t" } + finally { debugPrint "OUT1t" }; + debugPrint "AFTER1t" + }; + + func t2() : async () { + try { + debugPrint "IN2"; + throw error "IN2"; + } + catch _ { debugPrint "CAUGHT2" } + finally { debugPrint "OUT2" }; + }; + + func t2r() : async () { + try { + debugPrint "IN2r"; + throw error "IN2r"; + } + catch _ { debugPrint "CAUGHT2r"; return } + finally { debugPrint "OUT2r" }; + debugPrint "DEAD2r" + }; + + func t2b() : async () { + label out try { + debugPrint "IN2b"; + throw error "IN2b"; + } + catch _ { debugPrint "CAUGHT2b"; break out } + finally { debugPrint "OUT2b" }; + debugPrint "AFTER2b" + }; + + func t2i() : async Int { + try { + debugPrint "IN2i"; + await async (); + throw error "IN2i"; + } + catch _ { debugPrint "CAUGHT2i"; 42 } + finally { debugPrint "OUT2i" }; + }; + + func t2t() : async () { + try { + debugPrint "IN2t"; + await m(); + throw error "IN2t"; + } + catch _ { debugPrint "CAUGHT2t"; assert false } + finally { debugPrint "OUT2t" }; + }; + + func t3() : async () { + try { + debugPrint "IN3"; + await m(); + return; + } + finally { debugPrint "OUT3" }; + }; + + // check that finally is not running twice + func t4() : async () { + try { + debugPrint "IN4"; + await m(); + } + finally { debugPrint "OUT4" }; + return; + }; + + func t5() : async () { + debugPrint "BEFORE5"; + label out try { + debugPrint "IN5"; + await m(); + break out; + debugPrint "DEAD5"; + } + finally { debugPrint "OUT5" }; + debugPrint "AFTER5" + }; + + func t6() : async () { + debugPrint "BEFORE6"; + label out try { + debugPrint "IN6"; + try { + debugPrint "InnerIN6"; + await m(); + debugPrint "InnerLIVE6"; + break out; + debugPrint "InnerDEAD6"; + } finally { debugPrint "InnerOUT6" }; + debugPrint "DEAD6"; + } + finally { debugPrint "OUT6" }; + debugPrint "AFTER6" + }; + + func t6t() : async () { + debugPrint "BEFORE6t"; + label out try { + debugPrint "IN6t"; + try { + debugPrint "InnerIN6t"; + await m(); + debugPrint "InnerLIVE6t"; + assert false; + debugPrint "InnerDEAD6t"; + } finally { debugPrint "InnerOUT6t" }; + debugPrint "DEAD6t"; + } + finally { debugPrint "OUT6t" }; + debugPrint "AFTERDEAD6t" + }; + + func t6c() : async () { + debugPrint "BEFORE6c"; + label out try { + debugPrint "IN6c"; + try { + debugPrint "InnerIN6c"; + await m(); + debugPrint "InnerLIVE6c"; + throw error "InnerIN6c"; + } catch _ { + debugPrint "InnerCATCH6c"; + assert false; + debugPrint "DEADCATCH6c"; + } finally { debugPrint "InnerOUT6c" }; + debugPrint "DEAD6c"; + } + finally { debugPrint "OUT6c" }; + debugPrint "AFTERDEAD6c" + }; + + func t6d() : async () { + debugPrint "BEFORE6d"; + label out try { + debugPrint "IN6d"; + try { + debugPrint "InnerIN6d"; + let fut = m(); + await fut; + debugPrint "InnerLIVE6d"; + await fut; + debugPrint "InnerLIVESTILL6d"; + assert false; + debugPrint "InnerDEAD6d"; + } finally { debugPrint "InnerOUT6d" }; + debugPrint "DEAD6d"; + } + finally { debugPrint "OUT6d" }; + debugPrint "AFTERDEAD6d" + }; + + // `await*` tests + func t7() : async* () { + debugPrint "BEFORE7"; + label out try { + debugPrint "IN7"; + try { + debugPrint "InnerIN7"; + let fut = m(); + await fut; + debugPrint "InnerLIVE7"; + await fut; + debugPrint "InnerLIVESTILL7"; + assert false; + debugPrint "InnerDEAD7"; + } finally { debugPrint "InnerOUT7" }; + debugPrint "DEAD7"; + } + finally { debugPrint "OUT7" }; + debugPrint "AFTERDEAD7" + }; + + func t8() : async () { + try { + debugPrint "IN8"; + // await* async* throw error "IN8" + // https://github.com/dfinity/motoko/issues/4578 + await* async* { throw error "IN8"; () } + } + catch _ { debugPrint "CAUGHT8" } + finally { debugPrint "OUT8" }; + }; + + func t8i() : async () { + // see: https://github.com/dfinity/motoko/issues/4578 + func inner() : async* () = async* { throw error "IN8i" }; + + try { + debugPrint "IN8i"; + await* inner() + } + catch _ { debugPrint "CAUGHT8i" } + finally { debugPrint "OUT8i" }; + }; + + func t8t() : async () { + func inner() : async* () = async* { debugPrint "InnerIN8t"; await m(); assert true }; + + try { + debugPrint "IN8t"; + await* inner() + } + finally { debugPrint "OUT8t" }; + }; + + func t9() : async* () { + try { + debugPrint "IN9"; + await m() + } + finally { debugPrint "OUT9" }; + }; + + public func go() : async () { + // These don't trap (for the interpreters) + await t0t(); + await t0l(); + await t0e(); + await t1(); + await t1t(); + await t2(); + await t2r(); + await t2b(); + ignore await t2i(); + await t3(); + await t4(); + await t5(); + await t6(); + await t8(); + await t8i(); + await* t9(); + try await async { throw error "From the other side"; /* issues/4578 */() } + catch e { debugPrint (errorMessage e) }; + + // These trap, and only work on drun + try /*ignore*/ await t0() catch _ {}; + try await t0r() catch _ {}; + try await t0d() catch _ {}; + try await t2t() catch _ {}; + try await t6c() catch _ {}; + try await t6t() catch _ {}; + try await t6d() catch _ {}; + try await t8t() catch _ {}; + + // other side problem tests + try await async { + debugPrint "OTHER SIDE"; + try { + ignore await async { 42 }; + assert false + } + finally debugPrint "OTHER SIDE: CLEANING UP"; + debugPrint "OTHER SIDE: DEAD"; + } + catch e { debugPrint (errorMessage e) }; + try await async { assert false } + catch e { debugPrint (errorMessage e) }; + + // fall-through test + var done = false; + try { + try { throw error "foo" } + finally { done := true } + } catch e { debugPrint ("OUTER CAUGHT: " # errorMessage e) }; + assert done; + + /// caveat: t7 won't return! + try await* t7() catch _ {} finally debugPrint "It's over"; + }; + + public func go2() : async () { + /// caveat: the `await*` won't return! + try await* async* { + await m(); + debugPrint "go2"; + assert false } + catch _ {} + finally debugPrint "It's so over"; + } +}; + +//SKIP ic-ref-run + +A.go(); //OR-CALL ingress go "DIDL\x00\x00" +//CALL ingress go2 "DIDL\x00\x00"