From 7e7d0d67de8285e1d6c589750191bce4f49aacb3 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Thu, 27 Oct 2022 09:16:46 +0200 Subject: Reorganize a bit the project --- .gitignore | 2 +- Makefile | 18 +- TODO.md | 213 ----- aeneas.opam | 29 - compiler/.ocamlformat | 1 + compiler/Assumed.ml | 300 ++++++ compiler/Collections.ml | 378 ++++++++ compiler/ConstStrings.ml | 7 + compiler/Contexts.ml | 472 ++++++++++ compiler/Cps.ml | 193 ++++ compiler/Crates.ml | 90 ++ compiler/Errors.ml | 2 + compiler/Expressions.ml | 118 +++ compiler/ExpressionsUtils.ml | 10 + compiler/ExtractToFStar.ml | 1638 ++++++++++++++++++++++++++++++++ compiler/FunsAnalysis.ml | 143 +++ compiler/Identifiers.ml | 139 +++ compiler/Interpreter.ml | 396 ++++++++ compiler/InterpreterBorrows.ml | 1580 +++++++++++++++++++++++++++++++ compiler/InterpreterBorrowsCore.ml | 1181 +++++++++++++++++++++++ compiler/InterpreterExpansion.ml | 733 +++++++++++++++ compiler/InterpreterExpressions.ml | 720 ++++++++++++++ compiler/InterpreterPaths.ml | 801 ++++++++++++++++ compiler/InterpreterProjectors.ml | 543 +++++++++++ compiler/InterpreterStatements.ml | 1370 +++++++++++++++++++++++++++ compiler/InterpreterUtils.ml | 245 +++++ compiler/Invariants.ml | 794 ++++++++++++++++ compiler/LlbcAst.ml | 205 ++++ compiler/LlbcAstUtils.ml | 73 ++ compiler/LlbcOfJson.ml | 915 ++++++++++++++++++ compiler/Logging.ml | 179 ++++ compiler/Meta.ml | 44 + compiler/Names.ml | 80 ++ compiler/OfJsonBasic.ml | 75 ++ compiler/PrePasses.ml | 54 ++ compiler/Print.ml | 1283 +++++++++++++++++++++++++ compiler/PrintPure.ml | 594 ++++++++++++ compiler/Pure.ml | 581 ++++++++++++ compiler/PureMicroPasses.ml | 1375 +++++++++++++++++++++++++++ compiler/PureToExtract.ml | 723 ++++++++++++++ compiler/PureTypeCheck.ml | 178 ++++ compiler/PureUtils.ml | 450 +++++++++ compiler/Scalars.ml | 59 ++ compiler/StringUtils.ml | 106 +++ compiler/Substitute.ml | 357 +++++++ compiler/SymbolicAst.ml | 98 ++ compiler/SymbolicToPure.ml | 1824 ++++++++++++++++++++++++++++++++++++ compiler/SynthesizeSymbolic.ml | 156 +++ compiler/Translate.ml | 871 +++++++++++++++++ compiler/TranslateCore.ml | 65 ++ compiler/Types.ml | 208 ++++ compiler/TypesAnalysis.ml | 328 +++++++ compiler/TypesUtils.ml | 190 ++++ compiler/Utils.ml | 6 + compiler/Values.ml | 844 +++++++++++++++++ compiler/ValuesUtils.ml | 121 +++ compiler/aeneas.opam | 29 + compiler/driver.ml | 208 ++++ compiler/dune | 48 + compiler/dune-project | 24 + compiler/fstar/Primitives.fst | 286 ++++++ dune-project | 24 - fstar/Primitives.fst | 286 ------ rust-scripts/Cargo.toml | 7 + rust-scripts/src/main.rs | 150 +++ rust-tests/Cargo.toml | 9 - rust-tests/src/main.rs | 150 --- src/.ocamlformat | 1 - src/Assumed.ml | 300 ------ src/Collections.ml | 378 -------- src/ConstStrings.ml | 7 - src/Contexts.ml | 472 ---------- src/Cps.ml | 193 ---- src/Crates.ml | 90 -- src/Errors.ml | 2 - src/Expressions.ml | 118 --- src/ExpressionsUtils.ml | 10 - src/ExtractToFStar.ml | 1638 -------------------------------- src/FunsAnalysis.ml | 143 --- src/Identifiers.ml | 139 --- src/Interpreter.ml | 396 -------- src/InterpreterBorrows.ml | 1580 ------------------------------- src/InterpreterBorrowsCore.ml | 1181 ----------------------- src/InterpreterExpansion.ml | 733 --------------- src/InterpreterExpressions.ml | 720 -------------- src/InterpreterPaths.ml | 801 ---------------- src/InterpreterProjectors.ml | 543 ----------- src/InterpreterStatements.ml | 1370 --------------------------- src/InterpreterUtils.ml | 245 ----- src/Invariants.ml | 794 ---------------- src/LlbcAst.ml | 205 ---- src/LlbcAstUtils.ml | 73 -- src/LlbcOfJson.ml | 915 ------------------ src/Logging.ml | 179 ---- src/Meta.ml | 44 - src/Names.ml | 80 -- src/OfJsonBasic.ml | 75 -- src/PrePasses.ml | 54 -- src/Print.ml | 1283 ------------------------- src/PrintPure.ml | 594 ------------ src/Pure.ml | 581 ------------ src/PureMicroPasses.ml | 1375 --------------------------- src/PureToExtract.ml | 723 -------------- src/PureTypeCheck.ml | 178 ---- src/PureUtils.ml | 450 --------- src/Scalars.ml | 59 -- src/StringUtils.ml | 106 --- src/Substitute.ml | 357 ------- src/SymbolicAst.ml | 98 -- src/SymbolicToPure.ml | 1824 ------------------------------------ src/SynthesizeSymbolic.ml | 156 --- src/Translate.ml | 871 ----------------- src/TranslateCore.ml | 65 -- src/Types.ml | 208 ---- src/TypesAnalysis.ml | 328 ------- src/TypesUtils.ml | 190 ---- src/Utils.ml | 6 - src/Values.ml | 844 ----------------- src/ValuesUtils.ml | 121 --- src/driver.ml | 208 ---- src/dune | 48 - 121 files changed, 24658 insertions(+), 24873 deletions(-) delete mode 100644 TODO.md delete mode 100644 aeneas.opam create mode 100644 compiler/.ocamlformat create mode 100644 compiler/Assumed.ml create mode 100644 compiler/Collections.ml create mode 100644 compiler/ConstStrings.ml create mode 100644 compiler/Contexts.ml create mode 100644 compiler/Cps.ml create mode 100644 compiler/Crates.ml create mode 100644 compiler/Errors.ml create mode 100644 compiler/Expressions.ml create mode 100644 compiler/ExpressionsUtils.ml create mode 100644 compiler/ExtractToFStar.ml create mode 100644 compiler/FunsAnalysis.ml create mode 100644 compiler/Identifiers.ml create mode 100644 compiler/Interpreter.ml create mode 100644 compiler/InterpreterBorrows.ml create mode 100644 compiler/InterpreterBorrowsCore.ml create mode 100644 compiler/InterpreterExpansion.ml create mode 100644 compiler/InterpreterExpressions.ml create mode 100644 compiler/InterpreterPaths.ml create mode 100644 compiler/InterpreterProjectors.ml create mode 100644 compiler/InterpreterStatements.ml create mode 100644 compiler/InterpreterUtils.ml create mode 100644 compiler/Invariants.ml create mode 100644 compiler/LlbcAst.ml create mode 100644 compiler/LlbcAstUtils.ml create mode 100644 compiler/LlbcOfJson.ml create mode 100644 compiler/Logging.ml create mode 100644 compiler/Meta.ml create mode 100644 compiler/Names.ml create mode 100644 compiler/OfJsonBasic.ml create mode 100644 compiler/PrePasses.ml create mode 100644 compiler/Print.ml create mode 100644 compiler/PrintPure.ml create mode 100644 compiler/Pure.ml create mode 100644 compiler/PureMicroPasses.ml create mode 100644 compiler/PureToExtract.ml create mode 100644 compiler/PureTypeCheck.ml create mode 100644 compiler/PureUtils.ml create mode 100644 compiler/Scalars.ml create mode 100644 compiler/StringUtils.ml create mode 100644 compiler/Substitute.ml create mode 100644 compiler/SymbolicAst.ml create mode 100644 compiler/SymbolicToPure.ml create mode 100644 compiler/SynthesizeSymbolic.ml create mode 100644 compiler/Translate.ml create mode 100644 compiler/TranslateCore.ml create mode 100644 compiler/Types.ml create mode 100644 compiler/TypesAnalysis.ml create mode 100644 compiler/TypesUtils.ml create mode 100644 compiler/Utils.ml create mode 100644 compiler/Values.ml create mode 100644 compiler/ValuesUtils.ml create mode 100644 compiler/aeneas.opam create mode 100644 compiler/driver.ml create mode 100644 compiler/dune create mode 100644 compiler/dune-project create mode 100644 compiler/fstar/Primitives.fst delete mode 100644 dune-project delete mode 100644 fstar/Primitives.fst create mode 100644 rust-scripts/Cargo.toml create mode 100644 rust-scripts/src/main.rs delete mode 100644 rust-tests/Cargo.toml delete mode 100644 rust-tests/src/main.rs delete mode 100644 src/.ocamlformat delete mode 100644 src/Assumed.ml delete mode 100644 src/Collections.ml delete mode 100644 src/ConstStrings.ml delete mode 100644 src/Contexts.ml delete mode 100644 src/Cps.ml delete mode 100644 src/Crates.ml delete mode 100644 src/Errors.ml delete mode 100644 src/Expressions.ml delete mode 100644 src/ExpressionsUtils.ml delete mode 100644 src/ExtractToFStar.ml delete mode 100644 src/FunsAnalysis.ml delete mode 100644 src/Identifiers.ml delete mode 100644 src/Interpreter.ml delete mode 100644 src/InterpreterBorrows.ml delete mode 100644 src/InterpreterBorrowsCore.ml delete mode 100644 src/InterpreterExpansion.ml delete mode 100644 src/InterpreterExpressions.ml delete mode 100644 src/InterpreterPaths.ml delete mode 100644 src/InterpreterProjectors.ml delete mode 100644 src/InterpreterStatements.ml delete mode 100644 src/InterpreterUtils.ml delete mode 100644 src/Invariants.ml delete mode 100644 src/LlbcAst.ml delete mode 100644 src/LlbcAstUtils.ml delete mode 100644 src/LlbcOfJson.ml delete mode 100644 src/Logging.ml delete mode 100644 src/Meta.ml delete mode 100644 src/Names.ml delete mode 100644 src/OfJsonBasic.ml delete mode 100644 src/PrePasses.ml delete mode 100644 src/Print.ml delete mode 100644 src/PrintPure.ml delete mode 100644 src/Pure.ml delete mode 100644 src/PureMicroPasses.ml delete mode 100644 src/PureToExtract.ml delete mode 100644 src/PureTypeCheck.ml delete mode 100644 src/PureUtils.ml delete mode 100644 src/Scalars.ml delete mode 100644 src/StringUtils.ml delete mode 100644 src/Substitute.ml delete mode 100644 src/SymbolicAst.ml delete mode 100644 src/SymbolicToPure.ml delete mode 100644 src/SynthesizeSymbolic.ml delete mode 100644 src/Translate.ml delete mode 100644 src/TranslateCore.ml delete mode 100644 src/Types.ml delete mode 100644 src/TypesAnalysis.ml delete mode 100644 src/TypesUtils.ml delete mode 100644 src/Utils.ml delete mode 100644 src/Values.ml delete mode 100644 src/ValuesUtils.ml delete mode 100644 src/driver.ml delete mode 100644 src/dune diff --git a/.gitignore b/.gitignore index 1f9bd6a1..489b6f1c 100644 --- a/.gitignore +++ b/.gitignore @@ -29,7 +29,7 @@ setup.log _opam/ # Rust working directory -rust-tests/target/ +rust-scripts/target/ # F* .depend diff --git a/Makefile b/Makefile index eb09d1a0..4779bd22 100644 --- a/Makefile +++ b/Makefile @@ -14,7 +14,7 @@ CHARON_TESTS_DIR = CHARON_OPTIONS = CHARON_TESTS_SRC = -AENEAS_DRIVER = src/driver.exe +AENEAS_DRIVER = driver.exe # The user can specify additional translation options for Aeneas: OPTIONS ?= @@ -35,11 +35,15 @@ build: build-driver build-lib doc .PHONY: build-driver build-driver: - dune build $(AENEAS_DRIVER) + cd compiler && dune build $(AENEAS_DRIVER) .PHONY: build-lib build-lib: - dune build src/aeneas.cmxs + cd compiler && dune build aeneas.cmxs + +.PHONY: doc +doc: + cd compiler && dune build @doc # Test the project by translating test files to F* .PHONY: tests @@ -100,11 +104,7 @@ trans-%: CHARON_TESTS_DIR = $(CHARON_HOME)/tests/llbc trans-polonius-%: CHARON_TESTS_DIR = $(CHARON_HOME)/tests-polonius/llbc trans-polonius-%: gen-llbc-polonius-% - dune exec -- $(AENEAS_DRIVER) $(CHARON_TESTS_DIR)/$*.llbc -dest $(DEST_DIR)/$(SUBDIR) $(TRANS_OPTIONS) + cd compiler && dune exec -- ./$(AENEAS_DRIVER) ../$(CHARON_TESTS_DIR)/$*.llbc -dest ../$(DEST_DIR)/$(SUBDIR) $(TRANS_OPTIONS) trans-%: gen-llbc-% - dune exec -- $(AENEAS_DRIVER) $(CHARON_TESTS_DIR)/$*.llbc -dest $(DEST_DIR)/$(SUBDIR) $(TRANS_OPTIONS) - -.PHONY: doc -doc: - dune build @doc + cd compiler && dune exec -- ./$(AENEAS_DRIVER) ../$(CHARON_TESTS_DIR)/$*.llbc -dest ../$(DEST_DIR)/$(SUBDIR) $(TRANS_OPTIONS) diff --git a/TODO.md b/TODO.md deleted file mode 100644 index 39a16cdd..00000000 --- a/TODO.md +++ /dev/null @@ -1,213 +0,0 @@ -# TODO - -0. Priority: - * update treatment of matches - * remove prepass - * update pure expressions - * update control-flow reconstruction (Charon) - -0. Improve treatments of error and state error monads. In particular, introduce - `return` and `fail`, and remove `Return` and `Fail`. - -0. replace all the `failwith` with `raise (Failure ...)`: in CPS, it messes - up with provenance tracking - -0. In SymbolicToPure we do a few simplifications on types and values (simplification - of box type, removal of tuples which contain exactly one field - some fields - may have been filtered for the backward functions...): there are already a - few sanity checks, but we may to add more of them, which would type check - entire expressions for instance. - -0. merge the "read determinant" and the "switch" occurrences to "match" - -0. reaggregate the ADTs - -0. when going from symbolic to pure, remove the useless tuples (as some fields - might be erased). - -0. Update the high-level comments, in particular in Values.ml - -0. Rename Pure -> PureAst - -0. For variables pretty names: we could try to use the meta places used for the - forward function input vars to compute pretty names for the backward functions - output vars. - -0. sanity checks in symbolic to pure! - -0. update the end borrows internal to abstractions to not introduce a Bottom - -0. remove AConcrete from avalue - -0. remove ABottom from avalue - -0. micro-passes for pure: - - remove unused variables - - remove useless function calls: - - calls which don't introduce values *if* they are followed by associated - backward calls (because they may panic!) - - calls which don't take inputs (can happen with backward functions - for - instance, if a rust function only returns shared borrows) - - monadic lets to matches - - no tuple deconstruction on returned monadic values (introduce intermediate - variables to deconstruct in two times) - - matching on values (ex.: `let Cons hd tl = ls in` ~~> - `match ls with | Nil -> Panic | Cons hd tl -> ...`) - -1. reorder the branches of matches - -1. stateful maps/sets modules (hashtbl?) - -1. Check the occurrence of visitors like visit_AEndedMutLoan: the parameters are - sometimes inverted! - -2. check types are not "infinite" - -3. in MIR, erased regions are completely erased (no list of erased regions...): - update functions like `ty_has_regions` (and rename to `ty_has_borrows`), - `erase_regions` - -4. check that no borrow_overwrites upon ending abstractions - -5. add a check in function inputs: ok to take as parameters symbolic values with - borrow parameters *if* they come from the "input abstractions". - In order to do this, add a symbolic value kind (would make things easier than - adding ad-hoc lookups...): `FunRet`, `FunGivenBack`, `SynthInput`, `SynthGivenBack` - Rk.: pay attention: we can't give borrows of borrows to functions, but borrows - are ok. - -6. add `mvalue` (meta values) stored in abstractions when ending loans - -8. The following doesn't work (if we don't expand the symbolic values): - ``` - fn f1<'c, T>(p : (&'c mut T, &'c mut T)) -> (&'c mut T, &'c mut T) - - fn f2<'a, 'b, T>(p: (&'a mut T, &'b mut T)) -> (&'a mut T, &'b mut T) - - let p1 = f1<'c>(p0); - let p2 = f2<'a, 'b>(p1); - ``` - (end borrows) - I think we should change the proj_loans to: - `AProjLoans of symbolic_value * (mvalue * aproj) list` - (to accumulate the given back values) - Then, once we collected all the borrows, we would convert it to: - `AEndedProjLoans of (mvalue * aproj) list` - If the list is empty, it means the value was not modified. - -9. The way we currently give back symbolic values to symbolic values (inside - abstractions) is wrong. - We get things like : - `AProjLoans (s0 <: &'a mut T) [AProjBorrows (s1 <: &'a mut T)]` - while in the case of `s1` we should ignore the outer borrow (what we give - back actually has type `T`...) - -10. Write "bodies" for the assumed functions. - -* write a function to check that the code we are about to synthesize is in the proper - subset. In particular: - * borrow overwrites - * type parameters instantiation - * uniform polymorphism - Also, write nice debug messages which refer to the original code in case - something fails. -* write an interesting example to study with Jonathan - -* add option for: `allow_borrow_overwrites_on_input_values` - (rather: `will_overwrite_input_borrows`) - (but always disallow borrow overwrites on returned values) - at the level of abstractions (not at the level of loans!) - -* invariant: if there is a `proj_loans rset1 (s:rty)` where `s` contains mutable - borrows, then: - * either there is exactly one `s` in the current context - * or there is exactly one `proj_borrows rset2 (s:rty<:rty')` which intersects - the `proj_loans ...` - However, one `proj_borrows s` may intersect several `proj_loans` (in which - case we will need to split the value given back - for now: disallow this - behaviour?). - -* remove the rule which says that we can end a borrow under an abstraction if - the corresponding loan is in the same abstraction. - Actually: update the rule, rather. - -* update end_borrow_get_borrow to keep track of the ignored borrows/loans as - outer borrows, and track the ids of the ignored shared loans? - or: make sure there are no parent abstractions when ending inner loans in - abstractions. - -* `ended_proj_loans` (with ghost value) - -* make the projected shared borrows more structured? I don't think that's necessary - -* add a `allow_borrow_overwrites` in the loan projectors. - -* During printing, contexts are often big, with many variables containing "bottom". - Some variables also actually never get assigned, especially when they are used - for auxiliary assignments which don't exist anymore (because they were merged - with other operations - for arithmetic operations, for instance). - Maybe we should register which variable has been assigned at least once, and - print only those (thus skipping a big part of the environment for some time). - -* Some variables have the same name. It might be good to also print their id - to disambiguate? - -* it would be good to find a "core", which implements the rules (like - "end_borrow") and on top of which we build more complex functions which - chose in which order to apply the rules, etc. This way we would make very - explicit where we need to insert sanity checks, what the preconditions are, - where invariants might be broken, etc. - -* intensively test with PLT-redex - -* remove the config parameters when they are useless - -# DONE - -* update the assignment to move the destination value (which will be overriden) - to a dummy variable, and end all the outer borrows. - Also update pop_frame. - -* Check what happens when symbolic borrows are not expanded (when looking for - borrows/abstractions to end). - -* Detect loops in end_borrow/end_abstraction - -* recheck give_back_symbolic_value (use regions!) - -* expand symbolic values which are primitively copyable upon using them as - function arguments or putting them in the return value, in order to deduplicate - those values. - Completion: we expand those values only upon copying them (that's enough). - -* invariant: if a symbolic value is present multiple times in the concrete environment, - it means it is primitively copyable - -* update the printing of mut_borrows and mut_loans ([s@0 <: ...]) and (s@0) - -* add a switch to allow general symbolic values (containing references, etc.) - or not. - -* split `apply_proj_borrows` into two: - * `apply_proj_borrows_on_input_values` : ... -> value -> rty -> avalue - * `apply_proj_borrows_on_given_back_values` : ... -> value -> avalue -> avalue - Actually: didn't do it: bad idea. - -* Reduce projectors to `_` (ignored) when there are no region intersections - -* Add a `Collections.ml` file, with `Map` and `Set` - -* improve the use of [comp] for composition of functions with continuations - -* derive [ord] for types - -* compute the region constraints for the type definitions - -* set of types with mutable borrows (what to do when type variables appear under - shared borrows?), nested borrows... - necessary to know what to return. - -* fix the static regions (with projectors) - Before that, introduce a sanity check to make sure we don't use static regions. - -* add a meta-value in shared borrows to carry the shared value diff --git a/aeneas.opam b/aeneas.opam deleted file mode 100644 index 4048f9a0..00000000 --- a/aeneas.opam +++ /dev/null @@ -1,29 +0,0 @@ -# This file is generated by dune, edit dune-project instead -opam-version: "2.0" -version: "0.1" -synopsis: "" -description: "" -maintainer: ["son.ho@inria.fr"] -authors: ["Son Ho" "Jonathan Protzenko" "Aymeric Fromherz" "Sidney Congard"] -license: "Apache-2.0" -homepage: "https://github.com/AeneasVerif/aeneas" -bug-reports: "https://github.com/AeneasVerif/aeneas/issues" -depends: [ - "dune" {>= "2.8"} - "odoc" {with-doc} -] -build: [ - ["dune" "subst"] {dev} - [ - "dune" - "build" - "-p" - name - "-j" - jobs - "@install" - "@runtest" {with-test} - "@doc" {with-doc} - ] -] -dev-repo: "git+https://github.com/AeneasVerif/aeneas.git" diff --git a/compiler/.ocamlformat b/compiler/.ocamlformat new file mode 100644 index 00000000..b0ae150e --- /dev/null +++ b/compiler/.ocamlformat @@ -0,0 +1 @@ +doc-comments=before \ No newline at end of file diff --git a/compiler/Assumed.ml b/compiler/Assumed.ml new file mode 100644 index 00000000..cb089c08 --- /dev/null +++ b/compiler/Assumed.ml @@ -0,0 +1,300 @@ +(** This module contains various utilities for the assumed functions. + + Note that [Box::free] is peculiar: we don't really handle it as a function, + because it is legal to free a box whose boxed value is [⊥] (it often + happens that we move a value out of a box before freeing this box). + Semantically speaking, we thus handle [Box::free] as a value drop and + not as a function call, and thus never need its signature. + + TODO: implementing the concrete evaluation functions for the assumed + functions is really annoying (see + [InterpreterStatements.eval_non_local_function_call_concrete]). + I think it should be possible, in most situations, to write bodies which + model the behaviour of those unsafe functions. For instance, [Box::deref_mut] + should simply be: + {[ + fn deref_mut<'a, T>(x : &'a mut Box) -> &'a mut T { + &mut ( *x ) // box dereferencement is a primitive operation + } + ]} + + For vectors, we could "cheat" by using the index as a field index (vectors + would be encoded as ADTs with a variable number of fields). Of course, it + would require a bit of engineering, but it would probably be quite lightweight + in the end. + {[ + Vec::get_mut<'a,T>(v : &'a mut Vec, i : usize) -> &'a mut T { + &mut ( ( *x ).i ) + } + ]} + *) + +open Names +open TypesUtils +module T = Types +module A = LlbcAst + +module Sig = struct + (** A few utilities *) + + let rvar_id_0 = T.RegionVarId.of_int 0 + let rvar_0 : T.RegionVarId.id T.region = T.Var rvar_id_0 + let rg_id_0 = T.RegionGroupId.of_int 0 + let tvar_id_0 = T.TypeVarId.of_int 0 + let tvar_0 : T.sty = T.TypeVar tvar_id_0 + + (** Region 'a of id 0 *) + let region_param_0 : T.region_var = { T.index = rvar_id_0; name = Some "'a" } + + (** Region group: [{ parent={}; regions:{'a of id 0} }] *) + let region_group_0 : T.region_var_group = + { T.id = rg_id_0; regions = [ rvar_id_0 ]; parents = [] } + + (** Type parameter [T] of id 0 *) + let type_param_0 : T.type_var = { T.index = tvar_id_0; name = "T" } + + let mk_ref_ty (r : T.RegionVarId.id T.region) (ty : T.sty) (is_mut : bool) : + T.sty = + let ref_kind = if is_mut then T.Mut else T.Shared in + mk_ref_ty r ty ref_kind + + (** [fn(&'a mut T, T) -> T] *) + let mem_replace_sig : A.fun_sig = + (* The signature fields *) + let region_params = [ region_param_0 ] (* <'a> *) in + let regions_hierarchy = [ region_group_0 ] (* [{<'a>}] *) in + let type_params = [ type_param_0 ] (* *) in + let inputs = + [ mk_ref_ty rvar_0 tvar_0 true (* &'a mut T *); tvar_0 (* T *) ] + in + let output = tvar_0 (* T *) in + { + region_params; + num_early_bound_regions = 0; + regions_hierarchy; + type_params; + inputs; + output; + } + + (** [fn(T) -> Box] *) + let box_new_sig : A.fun_sig = + { + region_params = []; + num_early_bound_regions = 0; + regions_hierarchy = []; + type_params = [ type_param_0 ] (* *); + inputs = [ tvar_0 (* T *) ]; + output = mk_box_ty tvar_0 (* Box *); + } + + (** [fn(Box) -> ()] *) + let box_free_sig : A.fun_sig = + { + region_params = []; + num_early_bound_regions = 0; + regions_hierarchy = []; + type_params = [ type_param_0 ] (* *); + inputs = [ mk_box_ty tvar_0 (* Box *) ]; + output = mk_unit_ty (* () *); + } + + (** Helper for [Box::deref_shared] and [Box::deref_mut]. + Returns: + [fn<'a, T>(&'a (mut) Box) -> &'a (mut) T] + *) + let box_deref_gen_sig (is_mut : bool) : A.fun_sig = + (* The signature fields *) + let region_params = [ region_param_0 ] in + let regions_hierarchy = [ region_group_0 ] (* <'a> *) in + { + region_params; + num_early_bound_regions = 0; + regions_hierarchy; + type_params = [ type_param_0 ] (* *); + inputs = + [ mk_ref_ty rvar_0 (mk_box_ty tvar_0) is_mut (* &'a (mut) Box *) ]; + output = mk_ref_ty rvar_0 tvar_0 is_mut (* &'a (mut) T *); + } + + (** [fn<'a, T>(&'a Box) -> &'a T] *) + let box_deref_shared_sig = box_deref_gen_sig false + + (** [fn<'a, T>(&'a mut Box) -> &'a mut T] *) + let box_deref_mut_sig = box_deref_gen_sig true + + (** [fn() -> Vec] *) + let vec_new_sig : A.fun_sig = + let region_params = [] in + let regions_hierarchy = [] in + let type_params = [ type_param_0 ] (* *) in + let inputs = [] in + let output = mk_vec_ty tvar_0 (* Vec *) in + { + region_params; + num_early_bound_regions = 0; + regions_hierarchy; + type_params; + inputs; + output; + } + + (** [fn(&'a mut Vec, T)] *) + let vec_push_sig : A.fun_sig = + (* The signature fields *) + let region_params = [ region_param_0 ] in + let regions_hierarchy = [ region_group_0 ] (* <'a> *) in + let type_params = [ type_param_0 ] (* *) in + let inputs = + [ + mk_ref_ty rvar_0 (mk_vec_ty tvar_0) true (* &'a mut Vec *); + tvar_0 (* T *); + ] + in + let output = mk_unit_ty (* () *) in + { + region_params; + num_early_bound_regions = 0; + regions_hierarchy; + type_params; + inputs; + output; + } + + (** [fn(&'a mut Vec, usize, T)] *) + let vec_insert_sig : A.fun_sig = + (* The signature fields *) + let region_params = [ region_param_0 ] in + let regions_hierarchy = [ region_group_0 ] (* <'a> *) in + let type_params = [ type_param_0 ] (* *) in + let inputs = + [ + mk_ref_ty rvar_0 (mk_vec_ty tvar_0) true (* &'a mut Vec *); + mk_usize_ty (* usize *); + tvar_0 (* T *); + ] + in + let output = mk_unit_ty (* () *) in + { + region_params; + num_early_bound_regions = 0; + regions_hierarchy; + type_params; + inputs; + output; + } + + (** [fn(&'a Vec) -> usize] *) + let vec_len_sig : A.fun_sig = + (* The signature fields *) + let region_params = [ region_param_0 ] in + let regions_hierarchy = [ region_group_0 ] (* <'a> *) in + let type_params = [ type_param_0 ] (* *) in + let inputs = + [ mk_ref_ty rvar_0 (mk_vec_ty tvar_0) false (* &'a Vec *) ] + in + let output = mk_usize_ty (* usize *) in + { + region_params; + num_early_bound_regions = 0; + regions_hierarchy; + type_params; + inputs; + output; + } + + (** Helper: + [fn(&'a (mut) Vec, usize) -> &'a (mut) T] + *) + let vec_index_gen_sig (is_mut : bool) : A.fun_sig = + (* The signature fields *) + let region_params = [ region_param_0 ] in + let regions_hierarchy = [ region_group_0 ] (* <'a> *) in + let type_params = [ type_param_0 ] (* *) in + let inputs = + [ + mk_ref_ty rvar_0 (mk_vec_ty tvar_0) is_mut (* &'a (mut) Vec *); + mk_usize_ty (* usize *); + ] + in + let output = mk_ref_ty rvar_0 tvar_0 is_mut (* &'a (mut) T *) in + { + region_params; + num_early_bound_regions = 0; + regions_hierarchy; + type_params; + inputs; + output; + } + + (** [fn(&'a Vec, usize) -> &'a T] *) + let vec_index_shared_sig : A.fun_sig = vec_index_gen_sig false + + (** [fn(&'a mut Vec, usize) -> &'a mut T] *) + let vec_index_mut_sig : A.fun_sig = vec_index_gen_sig true +end + +type assumed_info = A.assumed_fun_id * A.fun_sig * bool * name + +(** The list of assumed functions and all their information: + - their signature + - a boolean indicating whether the function can fail or not + - their name + + Rk.: following what is written above, we don't include [Box::free]. + + Remark about the vector functions: for [Vec::len] to be correct and return + a [usize], we have to make sure that vectors are bounded by the max usize. + Followingly, [Vec::push] is monadic. + *) +let assumed_infos : assumed_info list = + let deref_pre = [ "core"; "ops"; "deref" ] in + let vec_pre = [ "alloc"; "vec"; "Vec" ] in + let index_pre = [ "core"; "ops"; "index" ] in + [ + (A.Replace, Sig.mem_replace_sig, false, to_name [ "core"; "mem"; "replace" ]); + (BoxNew, Sig.box_new_sig, false, to_name [ "alloc"; "boxed"; "Box"; "new" ]); + ( BoxFree, + Sig.box_free_sig, + false, + to_name [ "alloc"; "boxed"; "Box"; "free" ] ); + ( BoxDeref, + Sig.box_deref_shared_sig, + false, + to_name (deref_pre @ [ "Deref"; "deref" ]) ); + ( BoxDerefMut, + Sig.box_deref_mut_sig, + false, + to_name (deref_pre @ [ "DerefMut"; "deref_mut" ]) ); + (VecNew, Sig.vec_new_sig, false, to_name (vec_pre @ [ "new" ])); + (VecPush, Sig.vec_push_sig, true, to_name (vec_pre @ [ "push" ])); + (VecInsert, Sig.vec_insert_sig, true, to_name (vec_pre @ [ "insert" ])); + (VecLen, Sig.vec_len_sig, false, to_name (vec_pre @ [ "len" ])); + ( VecIndex, + Sig.vec_index_shared_sig, + true, + to_name (index_pre @ [ "Index"; "index" ]) ); + ( VecIndexMut, + Sig.vec_index_mut_sig, + true, + to_name (index_pre @ [ "IndexMut"; "index_mut" ]) ); + ] + +let get_assumed_info (id : A.assumed_fun_id) : assumed_info = + match List.find_opt (fun (id', _, _, _) -> id = id') assumed_infos with + | Some info -> info + | None -> + raise + (Failure ("get_assumed_info: not found: " ^ A.show_assumed_fun_id id)) + +let get_assumed_sig (id : A.assumed_fun_id) : A.fun_sig = + let _, sg, _, _ = get_assumed_info id in + sg + +let get_assumed_name (id : A.assumed_fun_id) : fun_name = + let _, _, _, name = get_assumed_info id in + name + +let assumed_can_fail (id : A.assumed_fun_id) : bool = + let _, _, b, _ = get_assumed_info id in + b diff --git a/compiler/Collections.ml b/compiler/Collections.ml new file mode 100644 index 00000000..0933b3e4 --- /dev/null +++ b/compiler/Collections.ml @@ -0,0 +1,378 @@ +(** The following file redefines several modules like Map or Set. *) + +module F = Format + +module List = struct + include List + + (** Split a list at a given index. + + [split_at ls i] splits [ls] into two lists where the first list has + length [i]. + + Raise [Failure] if the list is too short. + *) + let rec split_at (ls : 'a list) (i : int) = + if i < 0 then raise (Invalid_argument "split_at take positive integers") + else if i = 0 then ([], ls) + else + match ls with + | [] -> + raise + (Failure "The int given to split_at should be <= the list's length") + | x :: ls' -> + let ls1, ls2 = split_at ls' (i - 1) in + (x :: ls1, ls2) + + (** Pop the last element of a list + + Raise [Failure] if the list is empty. + *) + let rec pop_last (ls : 'a list) : 'a list * 'a = + match ls with + | [] -> raise (Failure "The list is empty") + | [ x ] -> ([], x) + | x :: ls -> + let ls, last = pop_last ls in + (x :: ls, last) + + (** Return the n first elements of the list *) + let prefix (n : int) (ls : 'a list) : 'a list = fst (split_at ls n) + + (** Iter and link the iterations. + + Iterate over a list, but call a function between every two elements + (but not before the first element, and not after the last). + *) + let iter_link (link : unit -> unit) (f : 'a -> unit) (ls : 'a list) : unit = + let rec iter ls = + match ls with + | [] -> () + | [ x ] -> f x + | x :: y :: ls -> + f x; + link (); + iter (y :: ls) + in + iter ls + + (** Fold and link the iterations. + + Similar to {!iter_link} but for fold left operations. + *) + let fold_left_link (link : unit -> unit) (f : 'a -> 'b -> 'a) (init : 'a) + (ls : 'b list) : 'a = + let rec fold (acc : 'a) (ls : 'b list) : 'a = + match ls with + | [] -> acc + | [ x ] -> f acc x + | x :: y :: ls -> + let acc = f acc x in + link (); + fold acc (y :: ls) + in + fold init ls + + let to_cons_nil (ls : 'a list) : 'a = + match ls with + | [ x ] -> x + | _ -> raise (Failure "The list should have length exactly one") + + let pop (ls : 'a list) : 'a * 'a list = + match ls with + | x :: ls' -> (x, ls') + | _ -> raise (Failure "The list should have length > 0") +end + +module type OrderedType = sig + include Map.OrderedType + + val to_string : t -> string + val pp_t : Format.formatter -> t -> unit + val show_t : t -> string +end + +(** Ordered string *) +module OrderedString : OrderedType with type t = string = struct + include String + + let to_string s = s + let pp_t fmt s = Format.pp_print_string fmt s + let show_t s = s +end + +module type Map = sig + include Map.S + + val add_list : (key * 'a) list -> 'a t -> 'a t + val of_list : (key * 'a) list -> 'a t + + (** "Simple" pretty printing function. + + Is useful when we need to customize a bit [show_t], but without using + something as burdensome as [pp_t]. + + [to_string (Some indent) m] prints [m] by breaking line after every binding + and inserting [indent]. + *) + val to_string : string option -> ('a -> string) -> 'a t -> string + + val pp : (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a t -> unit + val show : ('a -> string) -> 'a t -> string +end + +module MakeMap (Ord : OrderedType) : Map with type key = Ord.t = struct + module Map = Map.Make (Ord) + include Map + + let add_list bl m = List.fold_left (fun s (key, e) -> add key e s) m bl + let of_list bl = add_list bl empty + + let to_string indent_opt a_to_string m = + let indent, break = + match indent_opt with Some indent -> (indent, "\n") | None -> ("", " ") + in + let sep = "," ^ break in + let ls = + Map.fold + (fun key v ls -> + (indent ^ Ord.to_string key ^ " -> " ^ a_to_string v) :: ls) + m [] + in + match ls with + | [] -> "{}" + | _ -> "{" ^ break ^ String.concat sep (List.rev ls) ^ break ^ "}" + + let pp (pp_a : Format.formatter -> 'a -> unit) (fmt : Format.formatter) + (m : 'a t) : unit = + let pp_string = F.pp_print_string fmt in + let pp_space () = F.pp_print_space fmt () in + pp_string "{"; + F.pp_open_box fmt 2; + Map.iter + (fun key x -> + Ord.pp_t fmt key; + pp_space (); + pp_string "->"; + pp_space (); + pp_a fmt x; + pp_string ","; + F.pp_print_break fmt 1 0) + m; + F.pp_close_box fmt (); + F.pp_print_break fmt 0 0; + pp_string "}" + + let show show_a m = to_string None show_a m +end + +module type Set = sig + include Set.S + + val add_list : elt list -> t -> t + val of_list : elt list -> t + + (** "Simple" pretty printing function. + + Is useful when we need to customize a bit [show_t], but without using + something as burdensome as [pp_t]. + + [to_string (Some indent) s] prints [s] by breaking line after every element + and inserting [indent]. + *) + val to_string : string option -> t -> string + + val pp : Format.formatter -> t -> unit + val show : t -> string + val pairwise_distinct : elt list -> bool +end + +module MakeSet (Ord : OrderedType) : Set with type elt = Ord.t = struct + module Set = Set.Make (Ord) + include Set + + let add_list bl s = List.fold_left (fun s e -> add e s) s bl + let of_list bl = add_list bl empty + + let to_string indent_opt m = + let indent, break = + match indent_opt with Some indent -> (indent, "\n") | None -> ("", " ") + in + let sep = "," ^ break in + let ls = Set.fold (fun v ls -> (indent ^ Ord.to_string v) :: ls) m [] in + match ls with + | [] -> "{}" + | _ -> "{" ^ break ^ String.concat sep (List.rev ls) ^ break ^ "}" + + let pp (fmt : Format.formatter) (m : t) : unit = + let pp_string = F.pp_print_string fmt in + pp_string "{"; + F.pp_open_box fmt 2; + Set.iter + (fun x -> + Ord.pp_t fmt x; + pp_string ","; + F.pp_print_break fmt 1 0) + m; + F.pp_close_box fmt (); + F.pp_print_break fmt 0 0; + pp_string "}" + + let show s = to_string None s + + let pairwise_distinct ls = + let s = ref empty in + let rec check ls = + match ls with + | [] -> true + | x :: ls' -> + if mem x !s then false + else ( + s := add x !s; + check ls') + in + check ls +end + +(** A map where the bindings are injective (i.e., if two keys are distinct, + their bindings are distinct). + + This is useful for instance when generating mappings from our internal + identifiers to names (i.e., strings) when generating code, in order to + make sure that we don't have potentially dangerous collisions. + *) +module type InjMap = sig + type key + type elem + type t + + val empty : t + val is_empty : t -> bool + val mem : key -> t -> bool + val add : key -> elem -> t -> t + val singleton : key -> elem -> t + val remove : key -> t -> t + val compare : (elem -> elem -> int) -> t -> t -> int + val equal : (elem -> elem -> bool) -> t -> t -> bool + val iter : (key -> elem -> unit) -> t -> unit + val fold : (key -> elem -> 'b -> 'b) -> t -> 'b -> 'b + val for_all : (key -> elem -> bool) -> t -> bool + val exists : (key -> elem -> bool) -> t -> bool + val filter : (key -> elem -> bool) -> t -> t + val partition : (key -> elem -> bool) -> t -> t * t + val cardinal : t -> int + val bindings : t -> (key * elem) list + val min_binding : t -> key * elem + val min_binding_opt : t -> (key * elem) option + val max_binding : t -> key * elem + val max_binding_opt : t -> (key * elem) option + val choose : t -> key * elem + val choose_opt : t -> (key * elem) option + val split : key -> t -> t * elem option * t + val find : key -> t -> elem + val find_opt : key -> t -> elem option + val find_first : (key -> bool) -> t -> key * elem + val find_first_opt : (key -> bool) -> t -> (key * elem) option + val find_last : (key -> bool) -> t -> key * elem + val find_last_opt : (key -> bool) -> t -> (key * elem) option + val to_seq : t -> (key * elem) Seq.t + val to_seq_from : key -> t -> (key * elem) Seq.t + val add_seq : (key * elem) Seq.t -> t -> t + val of_seq : (key * elem) Seq.t -> t + val add_list : (key * elem) list -> t -> t + val of_list : (key * elem) list -> t +end + +(** See {!InjMap} *) +module MakeInjMap (Key : OrderedType) (Elem : OrderedType) : + InjMap with type key = Key.t with type elem = Elem.t = struct + module Map = MakeMap (Key) + module Set = MakeSet (Elem) + + type key = Key.t + type elem = Elem.t + type t = { map : elem Map.t; elems : Set.t } + + let empty = { map = Map.empty; elems = Set.empty } + let is_empty m = Map.is_empty m.map + let mem k m = Map.mem k m.map + + let add k e m = + assert (not (Set.mem e m.elems)); + { map = Map.add k e m.map; elems = Set.add e m.elems } + + let singleton k e = { map = Map.singleton k e; elems = Set.singleton e } + + let remove k m = + match Map.find_opt k m.map with + | None -> m + | Some x -> { map = Map.remove k m.map; elems = Set.remove x m.elems } + + let compare f m1 m2 = Map.compare f m1.map m2.map + let equal f m1 m2 = Map.equal f m1.map m2.map + let iter f m = Map.iter f m.map + let fold f m x = Map.fold f m.map x + let for_all f m = Map.for_all f m.map + let exists f m = Map.exists f m.map + + (** Small helper *) + let bindings_to_elems_set (bls : (key * elem) list) : Set.t = + let elems = List.map snd bls in + let elems = List.fold_left (fun s e -> Set.add e s) Set.empty elems in + elems + + (** Small helper *) + let map_to_elems_set (map : elem Map.t) : Set.t = + bindings_to_elems_set (Map.bindings map) + + (** Small helper *) + let map_to_t (map : elem Map.t) : t = + let elems = map_to_elems_set map in + { map; elems } + + let filter f m = + let map = Map.filter f m.map in + let elems = map_to_elems_set map in + { map; elems } + + let partition f m = + let map1, map2 = Map.partition f m.map in + (map_to_t map1, map_to_t map2) + + let cardinal m = Map.cardinal m.map + let bindings m = Map.bindings m.map + let min_binding m = Map.min_binding m.map + let min_binding_opt m = Map.min_binding_opt m.map + let max_binding m = Map.max_binding m.map + let max_binding_opt m = Map.max_binding_opt m.map + let choose m = Map.choose m.map + let choose_opt m = Map.choose_opt m.map + + let split k m = + let l, data, r = Map.split k m.map in + let l = map_to_t l in + let r = map_to_t r in + (l, data, r) + + let find k m = Map.find k m.map + let find_opt k m = Map.find_opt k m.map + let find_first k m = Map.find_first k m.map + let find_first_opt k m = Map.find_first_opt k m.map + let find_last k m = Map.find_last k m.map + let find_last_opt k m = Map.find_last_opt k m.map + let to_seq m = Map.to_seq m.map + let to_seq_from k m = Map.to_seq_from k m.map + + let rec add_seq s m = + (* Note that it is important to check that we don't add bindings mapping + * to the same element *) + match s () with + | Seq.Nil -> m + | Seq.Cons ((k, e), s) -> + let m = add k e m in + add_seq s m + + let of_seq s = add_seq s empty + let add_list ls m = List.fold_left (fun m (key, elem) -> add key elem m) m ls + let of_list ls = add_list ls empty +end diff --git a/compiler/ConstStrings.ml b/compiler/ConstStrings.ml new file mode 100644 index 00000000..ae169a2e --- /dev/null +++ b/compiler/ConstStrings.ml @@ -0,0 +1,7 @@ +(** Some utilities *) + +(** Basename for state variables (introduced when using state-error monads) *) +let state_basename = "st" + +(** ADT constructor prefix (used when pretty-printing) *) +let constructor_prefix = "Mk" diff --git a/compiler/Contexts.ml b/compiler/Contexts.ml new file mode 100644 index 00000000..510976f4 --- /dev/null +++ b/compiler/Contexts.ml @@ -0,0 +1,472 @@ +open Types +open Values +open LlbcAst +module V = Values +open ValuesUtils + +(** Some global counters. + + Note that those counters were initially stored in {!eval_ctx} values, + but it proved better to make them global and stateful: + - when branching (and thus executing on several paths with different + contexts) it is better to really have unique ids everywhere (and + not have fresh ids shared by several contexts even though introduced + after the branching) because at some point we might need to merge the + different contexts + - also, it is a lot more convenient to not store those counters in contexts + objects + + ============= + **WARNING**: + ============= + Pay attention when playing with closures, as you may not always generate + fresh identifiers without noticing it, especially when using type abbreviations. + For instance, consider the following: + {[ + type fun_type = unit -> ... + fn f x : fun_type = + let id = fresh_id () in + ... + + let g = f x in // <-- the fresh identifier gets generated here + let x1 = g () in // <-- no fresh generation here + let x2 = g () in + ... + ]} + + This is why, in such cases, we often introduce all the inputs, even + when they are not used (which happens!). + {[ + fn f x : fun_type = + fun .. -> + let id = fresh_id () in + ... + ]} + + Note that in practice, we never reuse closures, except when evaluating + a branching in the execution (which is fine, because the branches evaluate + independentely of each other). Still, it is always a good idea to be + defensive. + + However, the same problem arises with logging. + + Also, a more defensive way would be to not use global references, and + store the counters in the evaluation context. This is actually what was + originally done, before we updated the code to use global counters because + it proved more convenient (and even before updating the code of the + interpreter to use CPS). + *) + +let symbolic_value_id_counter, fresh_symbolic_value_id = + SymbolicValueId.fresh_stateful_generator () + +let borrow_id_counter, fresh_borrow_id = BorrowId.fresh_stateful_generator () +let region_id_counter, fresh_region_id = RegionId.fresh_stateful_generator () + +let abstraction_id_counter, fresh_abstraction_id = + AbstractionId.fresh_stateful_generator () + +let fun_call_id_counter, fresh_fun_call_id = + FunCallId.fresh_stateful_generator () + +(** We shouldn't need to reset the global counters, but it might be good to + do it from time to time, for instance every time we start evaluating/ + synthesizing a function. + + The reasons are manifold: + - it might prevent the counters from overflowing (although this seems + extremely unlikely - as a side node: we have overflow checks to make + sure the synthesis doesn't get impacted by potential overflows) + - most importantly, it allows to always manipulate low values, which + is always a lot more readable when debugging + *) +let reset_global_counters () = + symbolic_value_id_counter := SymbolicValueId.generator_zero; + borrow_id_counter := BorrowId.generator_zero; + region_id_counter := RegionId.generator_zero; + abstraction_id_counter := AbstractionId.generator_zero; + fun_call_id_counter := FunCallId.generator_zero + +(** A binder used in an environment, to map a variable to a value *) +type binder = { + index : VarId.id; (** Unique variable identifier *) + name : string option; (** Possible name *) +} +[@@deriving show] + +(** Environment value: mapping from variable to value, abstraction (only + used in symbolic mode) or stack frame delimiter. + + TODO: rename Var (-> Binding?) + *) +type env_elem = + | Var of (binder option[@opaque]) * typed_value + (** Variable binding - the binder is None if the variable is a dummy variable + (we use dummy variables to store temporaries while doing bookkeeping such + as ending borrows for instance). *) + | Abs of abs + | Frame +[@@deriving + show, + visitors + { + name = "iter_env_elem"; + variety = "iter"; + ancestors = [ "iter_abs" ]; + nude = true (* Don't inherit {!VisitorsRuntime.iter} *); + concrete = true; + }, + visitors + { + name = "map_env_elem"; + variety = "map"; + ancestors = [ "map_abs" ]; + nude = true (* Don't inherit {!VisitorsRuntime.iter} *); + concrete = true; + }] + +type env = env_elem list +[@@deriving + show, + visitors + { + name = "iter_env"; + variety = "iter"; + ancestors = [ "iter_env_elem" ]; + nude = true (* Don't inherit {!VisitorsRuntime.iter} *); + concrete = true; + }, + visitors + { + name = "map_env"; + variety = "map"; + ancestors = [ "map_env_elem" ]; + nude = true (* Don't inherit {!VisitorsRuntime.iter} *); + concrete = true; + }] + +type interpreter_mode = ConcreteMode | SymbolicMode [@@deriving show] + +type config = { + mode : interpreter_mode; + (** Concrete mode (interpreter) or symbolic mode (for synthesis) **) + check_invariants : bool; + (** Check that invariants are maintained whenever we execute a statement *) + greedy_expand_symbolics_with_borrows : bool; + (** Expand all symbolic values containing borrows upon introduction - allows + to use restrict ourselves to a simpler model for the projectors over + symbolic values. + The interpreter fails if doing this requires to do a branching (because + we need to expand an enumeration with strictly more than one variant) + or if we need to expand a recursive type (because this leads to looping). + *) + allow_bottom_below_borrow : bool; + (** Experimental. + + We sometimes want to temporarily break the invariant that there is no + bottom value below a borrow. If this value is true, we don't check + the invariant, and the rule becomes: we can't end a borrow *if* it contains + a bottom value. The consequence is that it becomes ok to temporarily + have bottom below a borrow, if we put something else inside before ending + the borrow. + + For instance, when evaluating an assignment, we move the value which + will be overwritten then do some administrative tasks with the borrows, + then move the rvalue to its destination. We currently want to be able + to check the invariants every time we end a borrow/an abstraction, + meaning at intermediate steps of the assignment where the invariants + might actually be broken. + *) + return_unit_end_abs_with_no_loans : bool; + (** If a function doesn't return any borrows, we can immediately call + its backward functions. If this option is on, whenever we call a + function *and* this function returns unit, we immediately end all the + abstractions which are introduced and don't contain loans. This can be + useful to make the code cleaner (the backward function is introduced + where the function call happened) and make sure all forward functions + with no return value are followed by a backward function. + *) +} +[@@deriving show] + +(** See {!config} *) +type partial_config = { + check_invariants : bool; + greedy_expand_symbolics_with_borrows : bool; + allow_bottom_below_borrow : bool; + return_unit_end_abs_with_no_loans : bool; +} + +let config_of_partial (mode : interpreter_mode) (config : partial_config) : + config = + { + mode; + check_invariants = config.check_invariants; + greedy_expand_symbolics_with_borrows = + config.greedy_expand_symbolics_with_borrows; + allow_bottom_below_borrow = config.allow_bottom_below_borrow; + return_unit_end_abs_with_no_loans = config.return_unit_end_abs_with_no_loans; + } + +type type_context = { + type_decls_groups : Crates.type_declaration_group TypeDeclId.Map.t; + type_decls : type_decl TypeDeclId.Map.t; + type_infos : TypesAnalysis.type_infos; +} +[@@deriving show] + +type fun_context = { fun_decls : fun_decl FunDeclId.Map.t } [@@deriving show] + +type global_context = { global_decls : global_decl GlobalDeclId.Map.t } +[@@deriving show] + +(** Evaluation context *) +type eval_ctx = { + type_context : type_context; + fun_context : fun_context; + global_context : global_context; + type_vars : type_var list; + env : env; + ended_regions : RegionId.Set.t; +} +[@@deriving show] + +let lookup_type_var (ctx : eval_ctx) (vid : TypeVarId.id) : type_var = + TypeVarId.nth ctx.type_vars vid + +let opt_binder_has_vid (bv : binder option) (vid : VarId.id) : bool = + match bv with Some bv -> bv.index = vid | None -> false + +let ctx_lookup_binder (ctx : eval_ctx) (vid : VarId.id) : binder = + (* TOOD: we might want to stop at the end of the frame *) + let rec lookup env = + match env with + | [] -> + raise (Invalid_argument ("Variable not found: " ^ VarId.to_string vid)) + | Var (var, _) :: env' -> + if opt_binder_has_vid var vid then Option.get var else lookup env' + | (Abs _ | Frame) :: env' -> lookup env' + in + lookup ctx.env + +(** TODO: make this more efficient with maps *) +let ctx_lookup_type_decl (ctx : eval_ctx) (tid : TypeDeclId.id) : type_decl = + TypeDeclId.Map.find tid ctx.type_context.type_decls + +(** TODO: make this more efficient with maps *) +let ctx_lookup_fun_decl (ctx : eval_ctx) (fid : FunDeclId.id) : fun_decl = + FunDeclId.Map.find fid ctx.fun_context.fun_decls + +(** TODO: make this more efficient with maps *) +let ctx_lookup_global_decl (ctx : eval_ctx) (gid : GlobalDeclId.id) : + global_decl = + GlobalDeclId.Map.find gid ctx.global_context.global_decls + +(** Retrieve a variable's value in an environment *) +let env_lookup_var_value (env : env) (vid : VarId.id) : typed_value = + (* We take care to stop at the end of current frame: different variables + in different frames can have the same id! + *) + let rec lookup env = + match env with + | [] -> failwith "Unexpected" + | Var (var, v) :: env' -> + if opt_binder_has_vid var vid then v else lookup env' + | Abs _ :: env' -> lookup env' + | Frame :: _ -> failwith "End of frame" + in + lookup env + +(** Retrieve a variable's value in an evaluation context *) +let ctx_lookup_var_value (ctx : eval_ctx) (vid : VarId.id) : typed_value = + env_lookup_var_value ctx.env vid + +(** Update a variable's value in an environment + + This is a helper function: it can break invariants and doesn't perform + any check. +*) +let env_update_var_value (env : env) (vid : VarId.id) (nv : typed_value) : env = + (* We take care to stop at the end of current frame: different variables + in different frames can have the same id! + *) + let rec update env = + match env with + | [] -> failwith "Unexpected" + | Var (var, v) :: env' -> + if opt_binder_has_vid var vid then Var (var, nv) :: env' + else Var (var, v) :: update env' + | Abs abs :: env' -> Abs abs :: update env' + | Frame :: _ -> failwith "End of frame" + in + update env + +let var_to_binder (var : var) : binder = { index = var.index; name = var.name } + +(** Update a variable's value in an evaluation context. + + This is a helper function: it can break invariants and doesn't perform + any check. +*) +let ctx_update_var_value (ctx : eval_ctx) (vid : VarId.id) (nv : typed_value) : + eval_ctx = + { ctx with env = env_update_var_value ctx.env vid nv } + +(** Push a variable in the context's environment. + + Checks that the pushed variable and its value have the same type (this + is important). +*) +let ctx_push_var (ctx : eval_ctx) (var : var) (v : typed_value) : eval_ctx = + assert (var.var_ty = v.ty); + let bv = var_to_binder var in + { ctx with env = Var (Some bv, v) :: ctx.env } + +(** Push a list of variables. + + Checks that the pushed variables and their values have the same type (this + is important). +*) +let ctx_push_vars (ctx : eval_ctx) (vars : (var * typed_value) list) : eval_ctx + = + assert ( + List.for_all + (fun (var, (value : typed_value)) -> var.var_ty = value.ty) + vars); + let vars = + List.map (fun (var, value) -> Var (Some (var_to_binder var), value)) vars + in + let vars = List.rev vars in + { ctx with env = List.append vars ctx.env } + +(** Push a dummy variable in the context's environment. *) +let ctx_push_dummy_var (ctx : eval_ctx) (v : typed_value) : eval_ctx = + { ctx with env = Var (None, v) :: ctx.env } + +(** Pop the first dummy variable from a context's environment. *) +let ctx_pop_dummy_var (ctx : eval_ctx) : eval_ctx * typed_value = + let rec pop_var (env : env) : env * typed_value = + match env with + | [] -> failwith "Could not find a dummy variable" + | Var (None, v) :: env -> (env, v) + | ee :: env -> + let env, v = pop_var env in + (ee :: env, v) + in + let env, v = pop_var ctx.env in + ({ ctx with env }, v) + +(** Read the first dummy variable in a context's environment. *) +let ctx_read_first_dummy_var (ctx : eval_ctx) : typed_value = + let rec read_var (env : env) : typed_value = + match env with + | [] -> failwith "Could not find a dummy variable" + | Var (None, v) :: _env -> v + | _ :: env -> read_var env + in + read_var ctx.env + +(** Push an uninitialized variable (which thus maps to {!Values.Bottom}) *) +let ctx_push_uninitialized_var (ctx : eval_ctx) (var : var) : eval_ctx = + ctx_push_var ctx var (mk_bottom var.var_ty) + +(** Push a list of uninitialized variables (which thus map to {!Values.Bottom}) *) +let ctx_push_uninitialized_vars (ctx : eval_ctx) (vars : var list) : eval_ctx = + let vars = List.map (fun v -> (v, mk_bottom v.var_ty)) vars in + ctx_push_vars ctx vars + +let env_lookup_abs (env : env) (abs_id : V.AbstractionId.id) : V.abs = + let rec lookup env = + match env with + | [] -> failwith "Unexpected" + | Var (_, _) :: env' -> lookup env' + | Abs abs :: env' -> if abs.abs_id = abs_id then abs else lookup env' + | Frame :: env' -> lookup env' + in + lookup env + +let ctx_lookup_abs (ctx : eval_ctx) (abs_id : V.AbstractionId.id) : V.abs = + env_lookup_abs ctx.env abs_id + +let ctx_type_decl_is_rec (ctx : eval_ctx) (id : TypeDeclId.id) : bool = + let decl_group = TypeDeclId.Map.find id ctx.type_context.type_decls_groups in + match decl_group with Crates.Rec _ -> true | Crates.NonRec _ -> false + +(** Visitor to iterate over the values in the *current* frame *) +class ['self] iter_frame = + object (self : 'self) + inherit [_] V.iter_abs + + method visit_Var : 'acc -> binder option -> typed_value -> unit = + fun acc _vid v -> self#visit_typed_value acc v + + method visit_Abs : 'acc -> abs -> unit = + fun acc abs -> self#visit_abs acc abs + + method visit_env_elem : 'acc -> env_elem -> unit = + fun acc em -> + match em with + | Var (vid, v) -> self#visit_Var acc vid v + | Abs abs -> self#visit_Abs acc abs + | Frame -> failwith "Unreachable" + + method visit_env : 'acc -> env -> unit = + fun acc env -> + match env with + | [] -> () + | Frame :: _ -> (* We stop here *) () + | em :: env -> + self#visit_env_elem acc em; + self#visit_env acc env + end + +(** Visitor to map over the values in the *current* frame *) +class ['self] map_frame_concrete = + object (self : 'self) + inherit [_] V.map_abs + + method visit_Var : 'acc -> binder option -> typed_value -> env_elem = + fun acc vid v -> + let v = self#visit_typed_value acc v in + Var (vid, v) + + method visit_Abs : 'acc -> abs -> env_elem = + fun acc abs -> Abs (self#visit_abs acc abs) + + method visit_env_elem : 'acc -> env_elem -> env_elem = + fun acc em -> + match em with + | Var (vid, v) -> self#visit_Var acc vid v + | Abs abs -> self#visit_Abs acc abs + | Frame -> failwith "Unreachable" + + method visit_env : 'acc -> env -> env = + fun acc env -> + match env with + | [] -> [] + | Frame :: env -> (* We stop here *) Frame :: env + | em :: env -> + let em = self#visit_env_elem acc em in + let env = self#visit_env acc env in + em :: env + end + +(** Visitor to iterate over the values in a context *) +class ['self] iter_eval_ctx = + object (_self : 'self) + inherit [_] iter_env as super + + method visit_eval_ctx : 'acc -> eval_ctx -> unit = + fun acc ctx -> super#visit_env acc ctx.env + end + +(** Visitor to map the values in a context *) +class ['self] map_eval_ctx = + object (_self : 'self) + inherit [_] map_env as super + + method visit_eval_ctx : 'acc -> eval_ctx -> eval_ctx = + fun acc ctx -> + let env = super#visit_env acc ctx.env in + { ctx with env } + end diff --git a/compiler/Cps.ml b/compiler/Cps.ml new file mode 100644 index 00000000..c2c0363b --- /dev/null +++ b/compiler/Cps.ml @@ -0,0 +1,193 @@ +(** This module defines various utilities to write the interpretation functions + in continuation passing style. *) + +module T = Types +module V = Values +module C = Contexts +module SA = SymbolicAst + +(** TODO: change the name *) +type eval_error = EPanic + +(** Result of evaluating a statement *) +type statement_eval_res = + | Unit + | Break of int + | Continue of int + | Return + | Panic + +(** Synthesized expresssion - dummy for now *) +type sexpr = SOne | SList of sexpr list + +type eval_result = SA.expression option + +(** Continuation function *) +type m_fun = C.eval_ctx -> eval_result + +(** Continuation taking another continuation as parameter *) +type cm_fun = m_fun -> m_fun + +(** Continuation taking a typed value as parameter - TODO: use more *) +type typed_value_m_fun = V.typed_value -> m_fun + +(** Continuation taking another continuation as parameter and a typed + value as parameter. + *) +type typed_value_cm_fun = V.typed_value -> cm_fun + +(** Type of a continuation used when evaluating a statement *) +type st_m_fun = statement_eval_res -> m_fun + +(** Type of a continuation used when evaluating a statement *) +type st_cm_fun = st_m_fun -> m_fun + +(** Convert a unit function to a cm function *) +let unit_to_cm_fun (f : C.eval_ctx -> unit) : cm_fun = + fun cf ctx -> + f ctx; + cf ctx + +(** *) +let update_to_cm_fun (f : C.eval_ctx -> C.eval_ctx) : cm_fun = + fun cf ctx -> + let ctx = f ctx in + cf ctx + +(** Composition of functions taking continuations as parameters. + We tried to make this as general as possible. *) +let comp (f : 'c -> 'd -> 'e) (g : ('a -> 'b) -> 'c) : ('a -> 'b) -> 'd -> 'e = + fun cf ctx -> f (g cf) ctx + +let comp_unit (f : cm_fun) (g : C.eval_ctx -> unit) : cm_fun = + comp f (unit_to_cm_fun g) + +let comp_update (f : cm_fun) (g : C.eval_ctx -> C.eval_ctx) : cm_fun = + comp f (update_to_cm_fun g) + +(** This is just a test, to check that {!comp} is general enough to handle a case + where a function must compute a value and give it to the continuation. + It happens for functions like {!InterpreterExpressions.eval_operand}. + + Keeping this here also makes it a good reference, when one wants to figure + out the signatures he should use for such a composition. + *) +let comp_ret_val (f : (V.typed_value -> m_fun) -> m_fun) + (g : m_fun -> V.typed_value -> m_fun) : cm_fun = + comp f g + +let apply (f : cm_fun) (g : m_fun) : m_fun = fun ctx -> f g ctx +let id_cm_fun : cm_fun = fun cf ctx -> cf ctx + +(** If we have a list of [inputs] of type ['a list] and a function [f] which + evaluates one element of type ['a] to compute a result of type ['b] before + giving it to a continuation, the following function performs a fold operation: + it evaluates all the inputs one by one by accumulating the results in a list, + and gives the list to a continuation. + + Note that we make sure that the results are listed in the order in + which they were computed (the first element of the list is the result + of applying [f] to the first element of the inputs). + + See the unit test below for an illustration. + *) +let fold_left_apply_continuation (f : 'a -> ('c -> 'd) -> 'c -> 'd) + (inputs : 'a list) (cf : 'c -> 'd) : 'c -> 'd = + let rec eval_list (inputs : 'a list) (cf : 'c -> 'd) : 'c -> 'd = + fun ctx -> + match inputs with + | [] -> cf ctx + | x :: inputs -> comp (f x) (fun cf -> eval_list inputs cf) cf ctx + in + eval_list inputs cf + +(** Unit test/example for {!fold_left_apply_continuation} *) +let _ = + fold_left_apply_continuation + (fun x cf (ctx : int) -> cf (ctx + x)) + [ 1; 20; 300; 4000 ] + (fun (ctx : int) -> assert (ctx = 4321)) + 0 + +(** If we have a list of [inputs] of type ['a list] and a function [f] which + evaluates one element of type ['a] to compute a result of type ['b] before + giving it to a continuation, the following function performs a fold operation: + it evaluates all the inputs one by one by accumulating the results in a list, + and gives the list to a continuation. + + Note that we make sure that the results are listed in the order in + which they were computed (the first element of the list is the result + of applying [f] to the first element of the inputs). + + See the unit test below for an illustration. + *) +let fold_left_list_apply_continuation (f : 'a -> ('b -> 'c -> 'd) -> 'c -> 'd) + (inputs : 'a list) (cf : 'b list -> 'c -> 'd) : 'c -> 'd = + let rec eval_list (inputs : 'a list) (cf : 'b list -> 'c -> 'd) + (outputs : 'b list) : 'c -> 'd = + fun ctx -> + match inputs with + | [] -> cf (List.rev outputs) ctx + | x :: inputs -> + comp (f x) (fun cf v -> eval_list inputs cf (v :: outputs)) cf ctx + in + eval_list inputs cf [] + +(** Unit test/example for {!fold_left_list_apply_continuation} *) +let _ = + fold_left_list_apply_continuation + (fun x cf (ctx : unit) -> cf (10 + x) ctx) + [ 0; 1; 2; 3; 4 ] + (fun values _ctx -> assert (values = [ 10; 11; 12; 13; 14 ])) + () + +(** Composition of functions taking continuations as parameters. + + We sometimes have the following situation, where we want to compose three + functions [send], [transmit] and [receive] such that: + - those three functions take continuations as parameters + - [send] generates a value and gives it to its continuation + - [receive] expects a value (so we can compose [send] and [receive] like + so: [comp send receive]) + - [transmit] doesn't expect any value and needs to be called between [send] + and [receive] + + In this situation, we need to take the value given by [send] and "transmit" + it to [receive]. + + This is what this function does (see the unit test below for an illustration). + *) +let comp_transmit (f : ('v -> 'm) -> 'n) (g : 'm -> 'm) : ('v -> 'm) -> 'n = + fun cf -> f (fun v -> g (cf v)) + +(** Example of use of {!comp_transmit} *) +let () = + let return3 (cf : int -> unit -> unit) (ctx : unit) = cf 3 ctx in + let do_nothing (cf : unit -> unit) (ctx : unit) = cf ctx in + let consume3 (x : int) (ctx : unit) : unit = + assert (x = 3); + ctx + in + let cc = comp_transmit return3 do_nothing in + let cc = cc consume3 in + cc () + +(** Sometimes, we want to compose a function with a continuation which checks + its computed value and its updated context, before transmitting them + *) +let comp_check_value (f : ('v -> 'ctx -> 'a) -> 'ctx -> 'b) + (g : 'v -> 'ctx -> unit) : ('v -> 'ctx -> 'a) -> 'ctx -> 'b = + fun cf -> + f (fun v ctx -> + g v ctx; + cf v ctx) + +(** This case is similar to {!comp_check_value}, but even simpler (we only check + the context) + *) +let comp_check_ctx (f : ('ctx -> 'a) -> 'ctx -> 'b) (g : 'ctx -> unit) : + ('ctx -> 'a) -> 'ctx -> 'b = + fun cf -> + f (fun ctx -> + g ctx; + cf ctx) diff --git a/compiler/Crates.ml b/compiler/Crates.ml new file mode 100644 index 00000000..844afb94 --- /dev/null +++ b/compiler/Crates.ml @@ -0,0 +1,90 @@ +open Types +open LlbcAst + +type 'id g_declaration_group = NonRec of 'id | Rec of 'id list +[@@deriving show] + +type type_declaration_group = TypeDeclId.id g_declaration_group +[@@deriving show] + +type fun_declaration_group = FunDeclId.id g_declaration_group [@@deriving show] + +(** Module declaration. Globals cannot be mutually recursive. *) +type declaration_group = + | Type of type_declaration_group + | Fun of fun_declaration_group + | Global of GlobalDeclId.id +[@@deriving show] + +type llbc_crate = { + name : string; + declarations : declaration_group list; + types : type_decl list; + functions : fun_decl list; + globals : global_decl list; +} +(** LLBC crate *) + +let compute_defs_maps (c : llbc_crate) : + type_decl TypeDeclId.Map.t + * fun_decl FunDeclId.Map.t + * global_decl GlobalDeclId.Map.t = + let types_map = + List.fold_left + (fun m (def : type_decl) -> TypeDeclId.Map.add def.def_id def m) + TypeDeclId.Map.empty c.types + in + let funs_map = + List.fold_left + (fun m (def : fun_decl) -> FunDeclId.Map.add def.def_id def m) + FunDeclId.Map.empty c.functions + in + let globals_map = + List.fold_left + (fun m (def : global_decl) -> GlobalDeclId.Map.add def.def_id def m) + GlobalDeclId.Map.empty c.globals + in + (types_map, funs_map, globals_map) + +(** Split a module's declarations between types, functions and globals *) +let split_declarations (decls : declaration_group list) : + type_declaration_group list + * fun_declaration_group list + * GlobalDeclId.id list = + let rec split decls = + match decls with + | [] -> ([], [], []) + | d :: decls' -> ( + let types, funs, globals = split decls' in + match d with + | Type decl -> (decl :: types, funs, globals) + | Fun decl -> (types, decl :: funs, globals) + | Global decl -> (types, funs, decl :: globals)) + in + split decls + +(** Split a module's declarations into three maps from type/fun/global ids to + declaration groups. + *) +let split_declarations_to_group_maps (decls : declaration_group list) : + type_declaration_group TypeDeclId.Map.t + * fun_declaration_group FunDeclId.Map.t + * GlobalDeclId.Set.t = + let module G (M : Map.S) = struct + let add_group (map : M.key g_declaration_group M.t) + (group : M.key g_declaration_group) : M.key g_declaration_group M.t = + match group with + | NonRec id -> M.add id group map + | Rec ids -> List.fold_left (fun map id -> M.add id group map) map ids + + let create_map (groups : M.key g_declaration_group list) : + M.key g_declaration_group M.t = + List.fold_left add_group M.empty groups + end in + let types, funs, globals = split_declarations decls in + let module TG = G (TypeDeclId.Map) in + let types = TG.create_map types in + let module FG = G (FunDeclId.Map) in + let funs = FG.create_map funs in + let globals = GlobalDeclId.Set.of_list globals in + (types, funs, globals) diff --git a/compiler/Errors.ml b/compiler/Errors.ml new file mode 100644 index 00000000..31a53cf4 --- /dev/null +++ b/compiler/Errors.ml @@ -0,0 +1,2 @@ +exception IntegerOverflow of unit +exception Unimplemented diff --git a/compiler/Expressions.ml b/compiler/Expressions.ml new file mode 100644 index 00000000..e2eaf1e7 --- /dev/null +++ b/compiler/Expressions.ml @@ -0,0 +1,118 @@ +open Types +open Values + +type field_proj_kind = + | ProjAdt of TypeDeclId.id * VariantId.id option + | ProjOption of VariantId.id + (** Option is an assumed type, coming from the standard library *) + | ProjTuple of int +[@@deriving show] +(* arity of the tuple *) + +type projection_elem = + | Deref + | DerefBox + | Field of field_proj_kind * FieldId.id +[@@deriving show] + +type projection = projection_elem list [@@deriving show] +type place = { var_id : VarId.id; projection : projection } [@@deriving show] +type borrow_kind = Shared | Mut | TwoPhaseMut [@@deriving show] + +type unop = + | Not + | Neg + | Cast of integer_type * integer_type + (** Cast an integer from a source type to a target type *) +[@@deriving show, ord] + +(** A binary operation + + Note that we merge checked binops and unchecked binops: we perform a + micro-pass on the MIR AST to remove the assertions introduced by rustc, + and later extract the binops which can fail (addition, substraction, etc.) + or have preconditions (division, remainder...) to monadic functions. + *) +type binop = + | BitXor + | BitAnd + | BitOr + | Eq + | Lt + | Le + | Ne + | Ge + | Gt + | Div + | Rem + | Add + | Sub + | Mul + | Shl + | Shr +[@@deriving show, ord] + +let all_binops = + [ + BitXor; + BitAnd; + BitOr; + Eq; + Lt; + Le; + Ne; + Ge; + Gt; + Div; + Rem; + Add; + Sub; + Mul; + Shl; + Shr; + ] + +type operand = + | Copy of place + | Move of place + | Constant of ety * constant_value +[@@deriving show] + +(** An aggregated ADT. + + Note that ADTs are desaggregated at some point in MIR. For instance, if + we have in Rust: + {[ + let ls = Cons(hd, tl); + ]} + + In MIR we have (yes, the discriminant update happens *at the end* for some + reason): + {[ + (ls as Cons).0 = move hd; + (ls as Cons).1 = move tl; + discriminant(ls) = 0; // assuming [Cons] is the variant of index 0 + ]} + + Note that in our semantics, we handle both cases (in case of desaggregated + initialization, [ls] is initialized to [⊥], then this [⊥] is expanded to + [Cons (⊥, ⊥)] upon the first assignment, at which point we can initialize + the field 0, etc.). + *) +type aggregate_kind = + | AggregatedTuple + | AggregatedOption of VariantId.id * ety + (* TODO: AggregatedOption should be merged with AggregatedAdt *) + | AggregatedAdt of + TypeDeclId.id * VariantId.id option * erased_region list * ety list +[@@deriving show] + +(* TODO: move the aggregate kind to operands *) +type rvalue = + | Use of operand + | Ref of place * borrow_kind + | UnaryOp of unop * operand + | BinaryOp of binop * operand * operand + | Discriminant of place + | Aggregate of aggregate_kind * operand list +[@@deriving show] diff --git a/compiler/ExpressionsUtils.ml b/compiler/ExpressionsUtils.ml new file mode 100644 index 00000000..c3ccfb15 --- /dev/null +++ b/compiler/ExpressionsUtils.ml @@ -0,0 +1,10 @@ +module E = Expressions + +let unop_can_fail (unop : E.unop) : bool = + match unop with Neg | Cast _ -> true | Not -> false + +let binop_can_fail (binop : E.binop) : bool = + match binop with + | BitXor | BitAnd | BitOr | Eq | Lt | Le | Ne | Ge | Gt -> false + | Div | Rem | Add | Sub | Mul -> true + | Shl | Shr -> raise Errors.Unimplemented diff --git a/compiler/ExtractToFStar.ml b/compiler/ExtractToFStar.ml new file mode 100644 index 00000000..5d212941 --- /dev/null +++ b/compiler/ExtractToFStar.ml @@ -0,0 +1,1638 @@ +(** Extract to F* *) + +open Errors +open Pure +open PureUtils +open TranslateCore +open PureToExtract +open StringUtils +module F = Format + +(** A qualifier for a type definition. + + Controls whether we should use [type ...] or [and ...] (for mutually + recursive datatypes). + *) +type type_decl_qualif = + | Type (** [type t = ...] *) + | And (** [type t0 = ... and t1 = ...] *) + | AssumeType (** [assume type t] *) + | TypeVal (** In an fsti: [val t : Type0] *) + +(** A qualifier for function definitions. + + Controls whether we should use [let ...], [let rec ...] or [and ...], + or only generate a declaration with [val] or [assume val] + *) +type fun_decl_qualif = Let | LetRec | And | Val | AssumeVal + +let fun_decl_qualif_keyword (qualif : fun_decl_qualif) : string = + match qualif with + | Let -> "let" + | LetRec -> "let rec" + | And -> "and" + | Val -> "val" + | AssumeVal -> "assume val" + +(** Small helper to compute the name of an int type *) +let fstar_int_name (int_ty : integer_type) = + match int_ty with + | Isize -> "isize" + | I8 -> "i8" + | I16 -> "i16" + | I32 -> "i32" + | I64 -> "i64" + | I128 -> "i128" + | Usize -> "usize" + | U8 -> "u8" + | U16 -> "u16" + | U32 -> "u32" + | U64 -> "u64" + | U128 -> "u128" + +(** Small helper to compute the name of a unary operation *) +let fstar_unop_name (unop : unop) : string = + match unop with + | Not -> "not" + | Neg int_ty -> fstar_int_name int_ty ^ "_neg" + | Cast _ -> raise (Failure "Unsupported") + +(** Small helper to compute the name of a binary operation (note that many + binary operations like "less than" are extracted to primitive operations, + like [<]. + *) +let fstar_named_binop_name (binop : E.binop) (int_ty : integer_type) : string = + let binop = + match binop with + | Div -> "div" + | Rem -> "rem" + | Add -> "add" + | Sub -> "sub" + | Mul -> "mul" + | _ -> raise (Failure "Unreachable") + in + fstar_int_name int_ty ^ "_" ^ binop + +(** A list of keywords/identifiers used in F* and with which we want to check + collision. *) +let fstar_keywords = + let named_unops = + fstar_unop_name Not + :: List.map (fun it -> fstar_unop_name (Neg it)) T.all_signed_int_types + in + let named_binops = [ E.Div; Rem; Add; Sub; Mul ] in + let named_binops = + List.concat + (List.map + (fun bn -> + List.map (fun it -> fstar_named_binop_name bn it) T.all_int_types) + named_binops) + in + let misc = + [ + "let"; + "rec"; + "in"; + "fn"; + "val"; + "int"; + "nat"; + "list"; + "FStar"; + "FStar.Mul"; + "type"; + "match"; + "with"; + "assert"; + "assert_norm"; + "Type0"; + "unit"; + "not"; + "scalar_cast"; + ] + in + List.concat [ named_unops; named_binops; misc ] + +let fstar_assumed_adts : (assumed_ty * string) list = + [ (State, "state"); (Result, "result"); (Option, "option"); (Vec, "vec") ] + +let fstar_assumed_structs : (assumed_ty * string) list = [] + +let fstar_assumed_variants : (assumed_ty * VariantId.id * string) list = + [ + (Result, result_return_id, "Return"); + (Result, result_fail_id, "Fail"); + (Option, option_some_id, "Some"); + (Option, option_none_id, "None"); + ] + +let fstar_assumed_functions : + (A.assumed_fun_id * T.RegionGroupId.id option * string) list = + let rg0 = Some T.RegionGroupId.zero in + [ + (Replace, None, "mem_replace_fwd"); + (Replace, rg0, "mem_replace_back"); + (VecNew, None, "vec_new"); + (VecPush, None, "vec_push_fwd") (* Shouldn't be used *); + (VecPush, rg0, "vec_push_back"); + (VecInsert, None, "vec_insert_fwd") (* Shouldn't be used *); + (VecInsert, rg0, "vec_insert_back"); + (VecLen, None, "vec_len"); + (VecIndex, None, "vec_index_fwd"); + (VecIndex, rg0, "vec_index_back") (* shouldn't be used *); + (VecIndexMut, None, "vec_index_mut_fwd"); + (VecIndexMut, rg0, "vec_index_mut_back"); + ] + +let fstar_names_map_init = + { + keywords = fstar_keywords; + assumed_adts = fstar_assumed_adts; + assumed_structs = fstar_assumed_structs; + assumed_variants = fstar_assumed_variants; + assumed_functions = fstar_assumed_functions; + } + +let fstar_extract_unop (extract_expr : bool -> texpression -> unit) + (fmt : F.formatter) (inside : bool) (unop : unop) (arg : texpression) : unit + = + match unop with + | Not | Neg _ -> + let unop = fstar_unop_name unop in + if inside then F.pp_print_string fmt "("; + F.pp_print_string fmt unop; + F.pp_print_space fmt (); + extract_expr true arg; + if inside then F.pp_print_string fmt ")" + | Cast (src, tgt) -> + (* The source type is an implicit parameter *) + if inside then F.pp_print_string fmt "("; + F.pp_print_string fmt "scalar_cast"; + F.pp_print_space fmt (); + F.pp_print_string fmt + (StringUtils.capitalize_first_letter + (PrintPure.integer_type_to_string src)); + F.pp_print_space fmt (); + F.pp_print_string fmt + (StringUtils.capitalize_first_letter + (PrintPure.integer_type_to_string tgt)); + F.pp_print_space fmt (); + extract_expr true arg; + if inside then F.pp_print_string fmt ")" + +let fstar_extract_binop (extract_expr : bool -> texpression -> unit) + (fmt : F.formatter) (inside : bool) (binop : E.binop) + (int_ty : integer_type) (arg0 : texpression) (arg1 : texpression) : unit = + if inside then F.pp_print_string fmt "("; + (* Some binary operations have a special treatment *) + (match binop with + | Eq | Lt | Le | Ne | Ge | Gt -> + let binop = + match binop with + | Eq -> "=" + | Lt -> "<" + | Le -> "<=" + | Ne -> "<>" + | Ge -> ">=" + | Gt -> ">" + | _ -> raise (Failure "Unreachable") + in + extract_expr false arg0; + F.pp_print_space fmt (); + F.pp_print_string fmt binop; + F.pp_print_space fmt (); + extract_expr false arg1 + | Div | Rem | Add | Sub | Mul -> + let binop = fstar_named_binop_name binop int_ty in + F.pp_print_string fmt binop; + F.pp_print_space fmt (); + extract_expr false arg0; + F.pp_print_space fmt (); + extract_expr false arg1 + | BitXor | BitAnd | BitOr | Shl | Shr -> raise Unimplemented); + if inside then F.pp_print_string fmt ")" + +(** + [ctx]: we use the context to lookup type definitions, to retrieve type names. + This is used to compute variable names, when they have no basenames: in this + case we use the first letter of the type name. + + [variant_concatenate_type_name]: if true, add the type name as a prefix + to the variant names. + Ex.: + In Rust: + {[ + enum List = { + Cons(u32, Box),x + Nil, + } + ]} + + F*, if option activated: + {[ + type list = + | ListCons : u32 -> list -> list + | ListNil : list + ]} + + F*, if option not activated: + {[ + type list = + | Cons : u32 -> list -> list + | Nil : list + ]} + + Rk.: this should be true by default, because in Rust all the variant names + are actively uniquely identifier by the type name [List::Cons(...)], while + in other languages it is not necessarily the case, and thus clashes can mess + up type checking. Note that some languages actually forbids the name clashes + (it is the case of F* ). + *) +let mk_formatter (ctx : trans_ctx) (crate_name : string) + (variant_concatenate_type_name : bool) : formatter = + let int_name = fstar_int_name in + + (* Prepare a name. + * The first id elem is always the crate: if it is the local crate, + * we remove it. + * We also remove all the disambiguators, then convert everything to strings. + * **Rmk:** because we remove the disambiguators, there may be name collisions + * (which is ok, because we check for name collisions and fail if there is any). + *) + let get_name (name : name) : string list = + (* Rmk.: initially we only filtered the disambiguators equal to 0 *) + let name = Names.filter_disambiguators name in + match name with + | Ident crate :: name -> + let name = if crate = crate_name then name else Ident crate :: name in + let name = + List.map + (function + | Names.Ident s -> s + | Disambiguator d -> Names.Disambiguator.to_string d) + name + in + name + | _ -> + raise (Failure ("Unexpected name shape: " ^ Print.name_to_string name)) + in + let get_type_name = get_name in + let type_name_to_camel_case name = + let name = get_type_name name in + let name = List.map to_camel_case name in + String.concat "" name + in + let type_name_to_snake_case name = + let name = get_type_name name in + let name = List.map to_snake_case name in + String.concat "_" name + in + let type_name name = type_name_to_snake_case name ^ "_t" in + let field_name (def_name : name) (field_id : FieldId.id) + (field_name : string option) : string = + let def_name = type_name_to_snake_case def_name ^ "_" in + match field_name with + | Some field_name -> def_name ^ field_name + | None -> def_name ^ FieldId.to_string field_id + in + let variant_name (def_name : name) (variant : string) : string = + let variant = to_camel_case variant in + if variant_concatenate_type_name then + type_name_to_camel_case def_name ^ variant + else variant + in + let struct_constructor (basename : name) : string = + let tname = type_name basename in + "Mk" ^ tname + in + let get_fun_name = get_name in + let fun_name_to_snake_case (fname : fun_name) : string = + let fname = get_fun_name fname in + (* Converting to snake case should be a no-op, but it doesn't cost much *) + let fname = List.map to_snake_case fname in + (* Concatenate the elements *) + String.concat "_" fname + in + let global_name (name : global_name) : string = + (* Converting to snake case also lowercases the letters (in Rust, global + * names are written in capital letters). *) + let parts = List.map to_snake_case (get_name name) in + String.concat "_" parts + in + let fun_name (_fid : A.fun_id) (fname : fun_name) (num_rgs : int) + (rg : region_group_info option) (filter_info : bool * int) : string = + let fname = fun_name_to_snake_case fname in + (* Compute the suffix *) + let suffix = default_fun_suffix num_rgs rg filter_info in + (* Concatenate *) + fname ^ suffix + in + + let decreases_clause_name (_fid : A.FunDeclId.id) (fname : fun_name) : string + = + let fname = fun_name_to_snake_case fname in + (* Compute the suffix *) + let suffix = "_decreases" in + (* Concatenate *) + fname ^ suffix + in + + let var_basename (_varset : StringSet.t) (basename : string option) (ty : ty) + : string = + (* If there is a basename, we use it *) + match basename with + | Some basename -> + (* This should be a no-op *) + to_snake_case basename + | None -> ( + (* No basename: we use the first letter of the type *) + match ty with + | Adt (type_id, tys) -> ( + match type_id with + | Tuple -> + (* The "pair" case is frequent enough to have its special treatment *) + if List.length tys = 2 then "p" else "t" + | Assumed Result -> "r" + | Assumed Option -> "opt" + | Assumed Vec -> "v" + | Assumed State -> "st" + | AdtId adt_id -> + let def = + TypeDeclId.Map.find adt_id ctx.type_context.type_decls + in + (* We do the following: + * - compute the type name, and retrieve the last ident + * - convert this to snake case + * - take the first letter of every "letter group" + * Ex.: ["hashmap"; "HashMap"] ~~> "HashMap" -> "hash_map" -> "hm" + *) + (* Thename shouldn't be empty, and its last element should + * be an ident *) + let cl = List.nth def.name (List.length def.name - 1) in + let cl = to_snake_case (Names.as_ident cl) in + let cl = String.split_on_char '_' cl in + let cl = List.filter (fun s -> String.length s > 0) cl in + assert (List.length cl > 0); + let cl = List.map (fun s -> s.[0]) cl in + StringUtils.string_of_chars cl) + | TypeVar _ -> "x" (* lacking imagination here... *) + | Bool -> "b" + | Char -> "c" + | Integer _ -> "i" + | Str -> "s" + | Arrow _ -> "f" + | Array _ | Slice _ -> raise Unimplemented) + in + let type_var_basename (_varset : StringSet.t) (basename : string) : string = + (* This is *not* a no-op: type variables in Rust often start with + * a capital letter *) + to_snake_case basename + in + let append_index (basename : string) (i : int) : string = + basename ^ string_of_int i + in + + let extract_constant_value (fmt : F.formatter) (_inside : bool) + (cv : constant_value) : unit = + match cv with + | Scalar sv -> F.pp_print_string fmt (Z.to_string sv.V.value) + | Bool b -> + let b = if b then "true" else "false" in + F.pp_print_string fmt b + | Char c -> F.pp_print_string fmt ("'" ^ String.make 1 c ^ "'") + | String s -> + (* We need to replace all the line breaks *) + let s = + StringUtils.map + (fun c -> if c = '\n' then "\n" else String.make 1 c) + s + in + F.pp_print_string fmt ("\"" ^ s ^ "\"") + in + { + bool_name = "bool"; + char_name = "char"; + int_name; + str_name = "string"; + field_name; + variant_name; + struct_constructor; + type_name; + global_name; + fun_name; + decreases_clause_name; + var_basename; + type_var_basename; + append_index; + extract_constant_value; + extract_unop = fstar_extract_unop; + extract_binop = fstar_extract_binop; + } + +(** [inside] constrols whether we should add parentheses or not around type + application (if [true] we add parentheses). + *) +let rec extract_ty (ctx : extraction_ctx) (fmt : F.formatter) (inside : bool) + (ty : ty) : unit = + match ty with + | Adt (type_id, tys) -> ( + match type_id with + | Tuple -> + (* This is a bit annoying, but in F* [()] is not the unit type: + * we have to write [unit]... *) + if tys = [] then F.pp_print_string fmt "unit" + else ( + F.pp_print_string fmt "("; + Collections.List.iter_link + (fun () -> + F.pp_print_space fmt (); + F.pp_print_string fmt "&"; + F.pp_print_space fmt ()) + (extract_ty ctx fmt true) tys; + F.pp_print_string fmt ")") + | AdtId _ | Assumed _ -> + let print_paren = inside && tys <> [] in + if print_paren then F.pp_print_string fmt "("; + F.pp_print_string fmt (ctx_get_type type_id ctx); + if tys <> [] then F.pp_print_space fmt (); + Collections.List.iter_link (F.pp_print_space fmt) + (extract_ty ctx fmt true) tys; + if print_paren then F.pp_print_string fmt ")") + | TypeVar vid -> F.pp_print_string fmt (ctx_get_type_var vid ctx) + | Bool -> F.pp_print_string fmt ctx.fmt.bool_name + | Char -> F.pp_print_string fmt ctx.fmt.char_name + | Integer int_ty -> F.pp_print_string fmt (ctx.fmt.int_name int_ty) + | Str -> F.pp_print_string fmt ctx.fmt.str_name + | Arrow (arg_ty, ret_ty) -> + if inside then F.pp_print_string fmt "("; + extract_ty ctx fmt false arg_ty; + F.pp_print_space fmt (); + F.pp_print_string fmt "->"; + F.pp_print_space fmt (); + extract_ty ctx fmt false ret_ty; + if inside then F.pp_print_string fmt ")" + | Array _ | Slice _ -> raise Unimplemented + +(** Compute the names for all the top-level identifiers used in a type + definition (type name, variant names, field names, etc. but not type + parameters). + + We need to do this preemptively, beforce extracting any definition, + because of recursive definitions. + *) +let extract_type_decl_register_names (ctx : extraction_ctx) (def : type_decl) : + extraction_ctx = + (* Compute and register the type def name *) + let ctx = ctx_add_type_decl def ctx in + (* Compute and register: + * - the variant names, if this is an enumeration + * - the field names, if this is a structure + *) + let ctx = + match def.kind with + | Struct fields -> + (* Add the fields *) + let ctx = + fst + (ctx_add_fields def (FieldId.mapi (fun id f -> (id, f)) fields) ctx) + in + (* Add the constructor name *) + fst (ctx_add_struct def ctx) + | Enum variants -> + fst + (ctx_add_variants def + (VariantId.mapi (fun id v -> (id, v)) variants) + ctx) + | Opaque -> + (* Nothing to do *) + ctx + in + (* Return *) + ctx + +let extract_type_decl_struct_body (ctx : extraction_ctx) (fmt : F.formatter) + (def : type_decl) (fields : field list) : unit = + (* We want to generate a definition which looks like this: + {[ + type t = { x : int; y : bool; } + ]} + + If there isn't enough space on one line: + {[ + type t = + { + x : int; y : bool; + } + ]} + + And if there is even less space: + {[ + type t = + { + x : int; + y : bool; + } + ]} + + Also, in case there are no fields, we need to define the type as [unit] + ([type t = {}] doesn't work in F* ). + *) + (* Note that we already printed: [type t =] *) + if fields = [] then ( + F.pp_print_space fmt (); + F.pp_print_string fmt "unit") + else ( + F.pp_print_space fmt (); + F.pp_print_string fmt "{"; + F.pp_print_break fmt 1 ctx.indent_incr; + (* The body itself *) + F.pp_open_hvbox fmt 0; + (* Print the fields *) + let print_field (field_id : FieldId.id) (f : field) : unit = + let field_name = ctx_get_field (AdtId def.def_id) field_id ctx in + F.pp_open_box fmt ctx.indent_incr; + F.pp_print_string fmt field_name; + F.pp_print_space fmt (); + F.pp_print_string fmt ":"; + F.pp_print_space fmt (); + extract_ty ctx fmt false f.field_ty; + F.pp_print_string fmt ";"; + F.pp_close_box fmt () + in + let fields = FieldId.mapi (fun fid f -> (fid, f)) fields in + Collections.List.iter_link (F.pp_print_space fmt) + (fun (fid, f) -> print_field fid f) + fields; + (* Close *) + F.pp_close_box fmt (); + F.pp_print_space fmt (); + F.pp_print_string fmt "}") + +let extract_type_decl_enum_body (ctx : extraction_ctx) (fmt : F.formatter) + (def : type_decl) (def_name : string) (type_params : string list) + (variants : variant list) : unit = + (* We want to generate a definition which looks like this: + {[ + type list a = | Cons : a -> list a -> list a | Nil : list a + ]} + + If there isn't enough space on one line: + {[ + type s = + | Cons : a -> list a -> list a + | Nil : list a + ]} + + And if we need to write the type of a variant on several lines: + {[ + type s = + | Cons : + a -> + list a -> + list a + | Nil : list a + ]} + + Finally, it is possible to give names to the variant fields in Rust. + In this situation, we generate a definition like this: + {[ + type s = + | Cons : hd:a -> tl:list a -> list a + | Nil : list a + ]} + + Note that we already printed: [type s =] + *) + (* Print the variants *) + let print_variant (variant_id : VariantId.id) (variant : variant) : unit = + let variant_name = ctx_get_variant (AdtId def.def_id) variant_id ctx in + F.pp_print_space fmt (); + F.pp_open_hvbox fmt ctx.indent_incr; + (* variant box *) + (* [| Cons :] + * Note that we really don't want any break above so we print everything + * at once. *) + F.pp_print_string fmt ("| " ^ variant_name ^ " :"); + F.pp_print_space fmt (); + let print_field (fid : FieldId.id) (f : field) (ctx : extraction_ctx) : + extraction_ctx = + (* Open the field box *) + F.pp_open_box fmt ctx.indent_incr; + (* Print the field names + * [ x :] + * Note that when printing fields, we register the field names as + * *variables*: they don't need to be unique at the top level. *) + let ctx = + match f.field_name with + | None -> ctx + | Some field_name -> + let var_id = VarId.of_int (FieldId.to_int fid) in + let field_name = + ctx.fmt.var_basename ctx.names_map.names_set (Some field_name) + f.field_ty + in + let ctx, field_name = ctx_add_var field_name var_id ctx in + F.pp_print_string fmt (field_name ^ " :"); + F.pp_print_space fmt (); + ctx + in + (* Print the field type *) + extract_ty ctx fmt false f.field_ty; + (* Print the arrow [->]*) + F.pp_print_space fmt (); + F.pp_print_string fmt "->"; + (* Close the field box *) + F.pp_close_box fmt (); + F.pp_print_space fmt (); + (* Return *) + ctx + in + (* Print the fields *) + let fields = FieldId.mapi (fun fid f -> (fid, f)) variant.fields in + let _ = + List.fold_left (fun ctx (fid, f) -> print_field fid f ctx) ctx fields + in + (* Print the final type *) + F.pp_open_hovbox fmt 0; + F.pp_print_string fmt def_name; + List.iter + (fun type_param -> + F.pp_print_space fmt (); + F.pp_print_string fmt type_param) + type_params; + F.pp_close_box fmt (); + (* Close the variant box *) + F.pp_close_box fmt () + in + (* Print the variants *) + let variants = VariantId.mapi (fun vid v -> (vid, v)) variants in + List.iter (fun (vid, v) -> print_variant vid v) variants + +(** Extract a type declaration. + + Note that all the names used for extraction should already have been + registered. + *) +let extract_type_decl (ctx : extraction_ctx) (fmt : F.formatter) + (qualif : type_decl_qualif) (def : type_decl) : unit = + (* Retrieve the definition name *) + let def_name = ctx_get_local_type def.def_id ctx in + (* Add the type params - note that we need those bindings only for the + * body translation (they are not top-level) *) + let ctx_body, type_params = ctx_add_type_params def.type_params ctx in + (* Add a break before *) + F.pp_print_break fmt 0 0; + (* Print a comment to link the extracted type to its original rust definition *) + F.pp_print_string fmt ("(** [" ^ Print.name_to_string def.name ^ "] *)"); + F.pp_print_space fmt (); + (* Open a box for the definition, so that whenever possible it gets printed on + * one line *) + F.pp_open_hvbox fmt 0; + (* Open a box for "type TYPE_NAME (TYPE_PARAMS) =" *) + F.pp_open_hovbox fmt ctx.indent_incr; + (* > "type TYPE_NAME" *) + let extract_body, qualif = + match qualif with + | Type -> (true, "type") + | And -> (true, "and") + | AssumeType -> (false, "assume type") + | TypeVal -> (false, "val") + in + F.pp_print_string fmt (qualif ^ " " ^ def_name); + (* Print the type parameters *) + if def.type_params <> [] then ( + F.pp_print_space fmt (); + F.pp_print_string fmt "("; + List.iter + (fun (p : type_var) -> + let pname = ctx_get_type_var p.index ctx_body in + F.pp_print_string fmt pname; + F.pp_print_space fmt ()) + def.type_params; + F.pp_print_string fmt ":"; + F.pp_print_space fmt (); + F.pp_print_string fmt "Type0)"); + (* Print the "=" if we extract the body*) + if extract_body then ( + F.pp_print_space fmt (); + F.pp_print_string fmt "=") + else ( + (* Otherwise print ": Type0" *) + F.pp_print_space fmt (); + F.pp_print_string fmt ":"; + F.pp_print_space fmt (); + F.pp_print_string fmt "Type0"); + (* Close the box for "type TYPE_NAME (TYPE_PARAMS) =" *) + F.pp_close_box fmt (); + (if extract_body then + match def.kind with + | Struct fields -> extract_type_decl_struct_body ctx_body fmt def fields + | Enum variants -> + extract_type_decl_enum_body ctx_body fmt def def_name type_params + variants + | Opaque -> raise (Failure "Unreachable")); + (* Close the box for the definition *) + F.pp_close_box fmt (); + (* Add breaks to insert new lines between definitions *) + F.pp_print_break fmt 0 0 + +(** Extract the state type declaration. *) +let extract_state_type (fmt : F.formatter) (ctx : extraction_ctx) + (qualif : type_decl_qualif) : unit = + (* Add a break before *) + F.pp_print_break fmt 0 0; + (* Print a comment *) + F.pp_print_string fmt "(** The state type used in the state-error monad *)"; + F.pp_print_space fmt (); + (* Open a box for the definition, so that whenever possible it gets printed on + * one line *) + F.pp_open_hvbox fmt 0; + (* Retrieve the name *) + let state_name = ctx_get_assumed_type State ctx in + (* The qualif should be [AssumeType] or [TypeVal] *) + (match qualif with + | Type | And -> raise (Failure "Unexpected") + | AssumeType -> + F.pp_print_string fmt "assume"; + F.pp_print_space fmt (); + F.pp_print_string fmt "type"; + F.pp_print_space fmt (); + F.pp_print_string fmt state_name; + F.pp_print_space fmt (); + F.pp_print_string fmt ":"; + F.pp_print_space fmt (); + F.pp_print_string fmt "Type0" + | TypeVal -> + F.pp_print_string fmt "val"; + F.pp_print_space fmt (); + F.pp_print_string fmt state_name; + F.pp_print_space fmt (); + F.pp_print_string fmt ":"; + F.pp_print_space fmt (); + F.pp_print_string fmt "Type0"); + (* Close the box for the definition *) + F.pp_close_box fmt (); + (* Add breaks to insert new lines between definitions *) + F.pp_print_break fmt 0 0 + +(** Compute the names for all the pure functions generated from a rust function + (forward function and backward functions). + *) +let extract_fun_decl_register_names (ctx : extraction_ctx) (keep_fwd : bool) + (has_decreases_clause : bool) (def : pure_fun_translation) : extraction_ctx + = + let fwd, back_ls = def in + (* Register the decrease clause, if necessary *) + let ctx = + if has_decreases_clause then ctx_add_decrases_clause fwd ctx else ctx + in + (* Register the forward function name *) + let ctx = ctx_add_fun_decl (keep_fwd, def) fwd ctx in + (* Register the backward functions' names *) + let ctx = + List.fold_left + (fun ctx back -> ctx_add_fun_decl (keep_fwd, def) back ctx) + ctx back_ls + in + (* Return *) + ctx + +(** Simply add the global name to the context. *) +let extract_global_decl_register_names (ctx : extraction_ctx) + (def : A.global_decl) : extraction_ctx = + ctx_add_global_decl_and_body def ctx + +(** The following function factorizes the extraction of ADT values. + + Note that patterns can introduce new variables: we thus return an extraction + context updated with new bindings. + + TODO: we don't need something very generic anymore + *) +let extract_adt_g_value + (extract_value : extraction_ctx -> bool -> 'v -> extraction_ctx) + (fmt : F.formatter) (ctx : extraction_ctx) (inside : bool) + (variant_id : VariantId.id option) (field_values : 'v list) (ty : ty) : + extraction_ctx = + match ty with + | Adt (Tuple, _) -> + (* Tuple *) + F.pp_print_string fmt "("; + let ctx = + Collections.List.fold_left_link + (fun () -> + F.pp_print_string fmt ","; + F.pp_print_space fmt ()) + (fun ctx v -> extract_value ctx false v) + ctx field_values + in + F.pp_print_string fmt ")"; + ctx + | Adt (adt_id, _) -> + (* "Regular" ADT *) + (* We print something of the form: [Cons field0 ... fieldn]. + * We could update the code to print something of the form: + * [{ field0=...; ...; fieldn=...; }] in case of structures. + *) + let cons = + match variant_id with + | Some vid -> ctx_get_variant adt_id vid ctx + | None -> ctx_get_struct adt_id ctx + in + if inside && field_values <> [] then F.pp_print_string fmt "("; + F.pp_print_string fmt cons; + let ctx = + Collections.List.fold_left + (fun ctx v -> + F.pp_print_space fmt (); + extract_value ctx true v) + ctx field_values + in + if inside && field_values <> [] then F.pp_print_string fmt ")"; + ctx + | _ -> raise (Failure "Inconsistent typed value") + +(* Extract globals in the same way as variables *) +let extract_global (ctx : extraction_ctx) (fmt : F.formatter) + (id : A.GlobalDeclId.id) : unit = + F.pp_print_string fmt (ctx_get_global id ctx) + +(** [inside]: see [extract_ty]. + + As a pattern can introduce new variables, we return an extraction context + updated with new bindings. + *) +let rec extract_typed_pattern (ctx : extraction_ctx) (fmt : F.formatter) + (inside : bool) (v : typed_pattern) : extraction_ctx = + match v.value with + | PatConcrete cv -> + ctx.fmt.extract_constant_value fmt inside cv; + ctx + | PatVar (v, _) -> + let vname = + ctx.fmt.var_basename ctx.names_map.names_set v.basename v.ty + in + let ctx, vname = ctx_add_var vname v.id ctx in + F.pp_print_string fmt vname; + ctx + | PatDummy -> + F.pp_print_string fmt "_"; + ctx + | PatAdt av -> + let extract_value ctx inside v = extract_typed_pattern ctx fmt inside v in + extract_adt_g_value extract_value fmt ctx inside av.variant_id + av.field_values v.ty + +(** [inside]: controls the introduction of parentheses. See [extract_ty] + + TODO: replace the formatting boolean [inside] with something more general? + Also, it seems we don't really use it... + Cases to consider: + - right-expression in a let: [let x = re in _] (never parentheses?) + - next expression in a let: [let x = _ in next_e] (never parentheses?) + - application argument: [f (exp)] + - match/if scrutinee: [if exp then _ else _]/[match exp | _ -> _] + *) +let rec extract_texpression (ctx : extraction_ctx) (fmt : F.formatter) + (inside : bool) (e : texpression) : unit = + match e.e with + | Var var_id -> + let var_name = ctx_get_var var_id ctx in + F.pp_print_string fmt var_name + | Const cv -> ctx.fmt.extract_constant_value fmt inside cv + | App _ -> + let app, args = destruct_apps e in + extract_App ctx fmt inside app args + | Abs _ -> + let xl, e = destruct_abs_list e in + extract_Abs ctx fmt inside xl e + | Qualif _ -> + (* We use the app case *) + extract_App ctx fmt inside e [] + | Let (monadic, lv, re, next_e) -> + extract_Let ctx fmt inside monadic lv re next_e + | Switch (scrut, body) -> extract_Switch ctx fmt inside scrut body + | Meta (_, e) -> extract_texpression ctx fmt inside e + +(* Extract an application *or* a top-level qualif (function extraction has + * to handle top-level qualifiers, so it seemed more natural to merge the + * two cases) *) +and extract_App (ctx : extraction_ctx) (fmt : F.formatter) (inside : bool) + (app : texpression) (args : texpression list) : unit = + (* We don't do the same thing if the app is a top-level identifier (function, + * ADT constructor...) or a "regular" expression *) + match app.e with + | Qualif qualif -> ( + (* Top-level qualifier *) + match qualif.id with + | Func fun_id -> + extract_function_call ctx fmt inside fun_id qualif.type_args args + | Global global_id -> extract_global ctx fmt global_id + | AdtCons adt_cons_id -> + extract_adt_cons ctx fmt inside adt_cons_id qualif.type_args args + | Proj proj -> + extract_field_projector ctx fmt inside app proj qualif.type_args args) + | _ -> + (* "Regular" expression *) + (* Open parentheses *) + if inside then F.pp_print_string fmt "("; + (* Open a box for the application *) + F.pp_open_hovbox fmt ctx.indent_incr; + (* Print the app expression *) + let app_inside = (inside && args = []) || args <> [] in + extract_texpression ctx fmt app_inside app; + (* Print the arguments *) + List.iter + (fun ve -> + F.pp_print_space fmt (); + extract_texpression ctx fmt true ve) + args; + (* Close the box for the application *) + F.pp_close_box fmt (); + (* Close parentheses *) + if inside then F.pp_print_string fmt ")" + +(** Subcase of the app case: function call *) +and extract_function_call (ctx : extraction_ctx) (fmt : F.formatter) + (inside : bool) (fid : fun_id) (type_args : ty list) + (args : texpression list) : unit = + match (fid, args) with + | Unop unop, [ arg ] -> + (* A unop can have *at most* one argument (the result can't be a function!). + * Note that the way we generate the translation, we shouldn't get the + * case where we have no argument (all functions are fully instantiated, + * and no AST transformation introduces partial calls). *) + ctx.fmt.extract_unop (extract_texpression ctx fmt) fmt inside unop arg + | Binop (binop, int_ty), [ arg0; arg1 ] -> + (* Number of arguments: similar to unop *) + ctx.fmt.extract_binop + (extract_texpression ctx fmt) + fmt inside binop int_ty arg0 arg1 + | Regular (fun_id, rg_id), _ -> + if inside then F.pp_print_string fmt "("; + (* Open a box for the function call *) + F.pp_open_hovbox fmt ctx.indent_incr; + (* Print the function name *) + let fun_name = ctx_get_function fun_id rg_id ctx in + F.pp_print_string fmt fun_name; + (* Print the type parameters *) + List.iter + (fun ty -> + F.pp_print_space fmt (); + extract_ty ctx fmt true ty) + type_args; + (* Print the arguments *) + List.iter + (fun ve -> + F.pp_print_space fmt (); + extract_texpression ctx fmt true ve) + args; + (* Close the box for the function call *) + F.pp_close_box fmt (); + (* Return *) + if inside then F.pp_print_string fmt ")" + | _ -> + raise + (Failure + ("Unreachable:\n" ^ "Function: " ^ show_fun_id fid + ^ ",\nNumber of arguments: " + ^ string_of_int (List.length args) + ^ ",\nArguments: " + ^ String.concat " " (List.map show_texpression args))) + +(** Subcase of the app case: ADT constructor *) +and extract_adt_cons (ctx : extraction_ctx) (fmt : F.formatter) (inside : bool) + (adt_cons : adt_cons_id) (type_args : ty list) (args : texpression list) : + unit = + match adt_cons.adt_id with + | Tuple -> + (* Tuple *) + (* For now, we only support fully applied tuple constructors *) + assert (List.length type_args = List.length args); + F.pp_print_string fmt "("; + Collections.List.iter_link + (fun () -> + F.pp_print_string fmt ","; + F.pp_print_space fmt ()) + (fun v -> extract_texpression ctx fmt false v) + args; + F.pp_print_string fmt ")" + | _ -> + (* "Regular" ADT *) + (* We print something of the form: [Cons field0 ... fieldn]. + * We could update the code to print something of the form: + * [{ field0=...; ...; fieldn=...; }] in case of fully + * applied structure constructors. + *) + let cons = + match adt_cons.variant_id with + | Some vid -> ctx_get_variant adt_cons.adt_id vid ctx + | None -> ctx_get_struct adt_cons.adt_id ctx + in + let use_parentheses = inside && args <> [] in + if use_parentheses then F.pp_print_string fmt "("; + F.pp_print_string fmt cons; + Collections.List.iter + (fun v -> + F.pp_print_space fmt (); + extract_texpression ctx fmt true v) + args; + if use_parentheses then F.pp_print_string fmt ")" + +(** Subcase of the app case: ADT field projector. *) +and extract_field_projector (ctx : extraction_ctx) (fmt : F.formatter) + (inside : bool) (original_app : texpression) (proj : projection) + (_proj_type_params : ty list) (args : texpression list) : unit = + (* We isolate the first argument (if there is), in order to pretty print the + * projection ([x.field] instead of [MkAdt?.field x] *) + match args with + | [ arg ] -> + (* Exactly one argument: pretty-print *) + let field_name = ctx_get_field proj.adt_id proj.field_id ctx in + (* Open a box *) + F.pp_open_hovbox fmt ctx.indent_incr; + (* Extract the expression *) + extract_texpression ctx fmt true arg; + (* We allow to break where the "." appears *) + F.pp_print_break fmt 0 0; + F.pp_print_string fmt "."; + F.pp_print_string fmt field_name; + (* Close the box *) + F.pp_close_box fmt () + | arg :: args -> + (* Call extract_App again, but in such a way that the first argument is + * isolated *) + extract_App ctx fmt inside (mk_app original_app arg) args + | [] -> + (* No argument: shouldn't happen *) + raise (Failure "Unreachable") + +and extract_Abs (ctx : extraction_ctx) (fmt : F.formatter) (inside : bool) + (xl : typed_pattern list) (e : texpression) : unit = + (* Open a box for the abs expression *) + F.pp_open_hovbox fmt ctx.indent_incr; + (* Open parentheses *) + if inside then F.pp_print_string fmt "("; + (* Print the lambda - note that there should always be at least one variable *) + assert (xl <> []); + F.pp_print_string fmt "fun"; + let ctx = + List.fold_left + (fun ctx x -> + F.pp_print_space fmt (); + extract_typed_pattern ctx fmt true x) + ctx xl + in + F.pp_print_space fmt (); + F.pp_print_string fmt "->"; + F.pp_print_space fmt (); + (* Print the body *) + extract_texpression ctx fmt false e; + (* Close parentheses *) + if inside then F.pp_print_string fmt ")"; + (* Close the box for the abs expression *) + F.pp_close_box fmt () + +and extract_Let (ctx : extraction_ctx) (fmt : F.formatter) (inside : bool) + (monadic : bool) (lv : typed_pattern) (re : texpression) + (next_e : texpression) : unit = + (* Open a box for the whole expression *) + F.pp_open_hvbox fmt 0; + (* Open parentheses *) + if inside then F.pp_print_string fmt "("; + (* Open a box for the let-binding *) + F.pp_open_hovbox fmt ctx.indent_incr; + let ctx = + if monadic then ( + (* Note that in F*, the left value of a monadic let-binding can only be + * a variable *) + let ctx = extract_typed_pattern ctx fmt true lv in + F.pp_print_space fmt (); + F.pp_print_string fmt "<--"; + F.pp_print_space fmt (); + extract_texpression ctx fmt false re; + F.pp_print_string fmt ";"; + ctx) + else ( + F.pp_print_string fmt "let"; + F.pp_print_space fmt (); + let ctx = extract_typed_pattern ctx fmt true lv in + F.pp_print_space fmt (); + F.pp_print_string fmt "="; + F.pp_print_space fmt (); + extract_texpression ctx fmt false re; + F.pp_print_space fmt (); + F.pp_print_string fmt "in"; + ctx) + in + (* Close the box for the let-binding *) + F.pp_close_box fmt (); + (* Print the next expression *) + F.pp_print_space fmt (); + extract_texpression ctx fmt false next_e; + (* Close parentheses *) + if inside then F.pp_print_string fmt ")"; + (* Close the box for the whole expression *) + F.pp_close_box fmt () + +and extract_Switch (ctx : extraction_ctx) (fmt : F.formatter) (inside : bool) + (scrut : texpression) (body : switch_body) : unit = + (* Open a box for the whole expression *) + F.pp_open_hvbox fmt 0; + (* Open parentheses *) + if inside then F.pp_print_string fmt "("; + (* Extract the switch *) + (match body with + | If (e_then, e_else) -> + (* Open a box for the [if] *) + F.pp_open_hovbox fmt ctx.indent_incr; + F.pp_print_string fmt "if"; + F.pp_print_space fmt (); + let scrut_inside = PureUtils.let_group_requires_parentheses scrut in + extract_texpression ctx fmt scrut_inside scrut; + (* Close the box for the [if] *) + F.pp_close_box fmt (); + (* Extract the branches *) + let extract_branch (is_then : bool) (e_branch : texpression) : unit = + F.pp_print_space fmt (); + (* Open a box for the then/else+branch *) + F.pp_open_hovbox fmt ctx.indent_incr; + let then_or_else = if is_then then "then" else "else" in + F.pp_print_string fmt then_or_else; + F.pp_print_space fmt (); + (* Open a box for the branch *) + F.pp_open_hovbox fmt ctx.indent_incr; + (* Print the [begin] if necessary *) + let parenth = PureUtils.let_group_requires_parentheses e_branch in + if parenth then ( + F.pp_print_string fmt "begin"; + F.pp_print_space fmt ()); + (* Print the branch expression *) + extract_texpression ctx fmt false e_branch; + (* Close the [begin ... end ] *) + if parenth then ( + F.pp_print_space fmt (); + F.pp_print_string fmt "end"); + (* Close the box for the branch *) + F.pp_close_box fmt (); + (* Close the box for the then/else+branch *) + F.pp_close_box fmt () + in + + extract_branch true e_then; + extract_branch false e_else + | Match branches -> + (* Open a box for the [match ... with] *) + F.pp_open_hovbox fmt ctx.indent_incr; + (* Print the [match ... with] *) + F.pp_print_string fmt "begin match"; + F.pp_print_space fmt (); + let scrut_inside = PureUtils.let_group_requires_parentheses scrut in + extract_texpression ctx fmt scrut_inside scrut; + F.pp_print_space fmt (); + F.pp_print_string fmt "with"; + (* Close the box for the [match ... with] *) + F.pp_close_box fmt (); + + (* Extract the branches *) + let extract_branch (br : match_branch) : unit = + F.pp_print_space fmt (); + (* Open a box for the pattern+branch *) + F.pp_open_hovbox fmt ctx.indent_incr; + F.pp_print_string fmt "|"; + (* Print the pattern *) + F.pp_print_space fmt (); + let ctx = extract_typed_pattern ctx fmt false br.pat in + F.pp_print_space fmt (); + F.pp_print_string fmt "->"; + F.pp_print_space fmt (); + (* Open a box for the branch *) + F.pp_open_hovbox fmt ctx.indent_incr; + (* Print the branch itself *) + extract_texpression ctx fmt false br.branch; + (* Close the box for the branch *) + F.pp_close_box fmt (); + (* Close the box for the pattern+branch *) + F.pp_close_box fmt () + in + + List.iter extract_branch branches; + + (* End the match *) + F.pp_print_space fmt (); + F.pp_print_string fmt "end"); + (* Close parentheses *) + if inside then F.pp_print_string fmt ")"; + (* Close the box for the whole expression *) + F.pp_close_box fmt () + +(** A small utility to print the parameters of a function signature. + + We return two contexts: + - the context augmented with bindings for the type parameters + - the previous context augmented with bindings for the input values + *) +let extract_fun_parameters (ctx : extraction_ctx) (fmt : F.formatter) + (def : fun_decl) : extraction_ctx * extraction_ctx = + (* Add the type parameters - note that we need those bindings only for the + * body translation (they are not top-level) *) + let ctx, _ = ctx_add_type_params def.signature.type_params ctx in + (* Print the parameters - rk.: we should have filtered the functions + * with no input parameters *) + (* The type parameters *) + if def.signature.type_params <> [] then ( + (* Open a box for the type parameters *) + F.pp_open_hovbox fmt 0; + F.pp_print_string fmt "("; + List.iter + (fun (p : type_var) -> + let pname = ctx_get_type_var p.index ctx in + F.pp_print_string fmt pname; + F.pp_print_space fmt ()) + def.signature.type_params; + F.pp_print_string fmt ":"; + F.pp_print_space fmt (); + F.pp_print_string fmt "Type0)"; + (* Close the box for the type parameters *) + F.pp_close_box fmt (); + F.pp_print_space fmt ()); + (* The input parameters - note that doing this adds bindings to the context *) + let ctx_body = + match def.body with + | None -> ctx + | Some body -> + List.fold_left + (fun ctx (lv : typed_pattern) -> + (* Open a box for the input parameter *) + F.pp_open_hovbox fmt 0; + F.pp_print_string fmt "("; + let ctx = extract_typed_pattern ctx fmt false lv in + F.pp_print_space fmt (); + F.pp_print_string fmt ":"; + F.pp_print_space fmt (); + extract_ty ctx fmt false lv.ty; + F.pp_print_string fmt ")"; + (* Close the box for the input parameters *) + F.pp_close_box fmt (); + F.pp_print_space fmt (); + ctx) + ctx body.inputs_lvs + in + (ctx, ctx_body) + +(** A small utility to print the types of the input parameters in the form: + [u32 -> list u32 -> ...] + (we don't print the return type of the function) + + This is used for opaque function declarations, in particular. + *) +let extract_fun_input_parameters_types (ctx : extraction_ctx) + (fmt : F.formatter) (def : fun_decl) : unit = + let extract_param (ty : ty) : unit = + let inside = false in + extract_ty ctx fmt inside ty; + F.pp_print_space fmt (); + F.pp_print_string fmt "->"; + F.pp_print_space fmt () + in + List.iter extract_param def.signature.inputs + +(** Extract a decrease clause function template body. + + In order to help the user, we can generate a template for the functions + required by the decreases clauses. We simply generate definitions of + the following form in a separate file: + {[ + let f_decrease (t : Type0) (x : t) : nat = admit() + ]} + + Where the translated functions for [f] look like this: + {[ + let f_fwd (t : Type0) (x : t) : Tot ... (decreases (f_decrease t x)) = ... + ]} + *) +let extract_template_decreases_clause (ctx : extraction_ctx) (fmt : F.formatter) + (def : fun_decl) : unit = + (* Retrieve the function name *) + let def_name = ctx_get_decreases_clause def.def_id ctx in + (* Add a break before *) + F.pp_print_break fmt 0 0; + (* Print a comment to link the extracted type to its original rust definition *) + F.pp_print_string fmt + ("(** [" ^ Print.fun_name_to_string def.basename ^ "]: decreases clause *)"); + F.pp_print_space fmt (); + (* Open a box for the definition, so that whenever possible it gets printed on + * one line *) + F.pp_open_hvbox fmt 0; + (* Add the [unfold] keyword *) + F.pp_print_string fmt "unfold"; + F.pp_print_space fmt (); + (* Open a box for "let FUN_NAME (PARAMS) : EFFECT = admit()" *) + F.pp_open_hvbox fmt ctx.indent_incr; + (* Open a box for "let FUN_NAME (PARAMS) : EFFECT =" *) + F.pp_open_hovbox fmt ctx.indent_incr; + (* > "let FUN_NAME" *) + F.pp_print_string fmt ("let " ^ def_name); + F.pp_print_space fmt (); + (* Extract the parameters *) + let _, _ = extract_fun_parameters ctx fmt def in + F.pp_print_string fmt ":"; + (* Print the signature *) + F.pp_print_space fmt (); + F.pp_print_string fmt "nat"; + (* Print the "=" *) + F.pp_print_space fmt (); + F.pp_print_string fmt "="; + (* Close the box for "let FUN_NAME (PARAMS) : EFFECT =" *) + F.pp_close_box fmt (); + F.pp_print_space fmt (); + (* Print the "admit ()" *) + F.pp_print_string fmt "admit ()"; + (* Close the box for "let FUN_NAME (PARAMS) : EFFECT = admit()" *) + F.pp_close_box fmt (); + (* Close the box for the whole definition *) + F.pp_close_box fmt (); + (* Add breaks to insert new lines between definitions *) + F.pp_print_break fmt 0 0 + +(** Extract a function declaration. + + Note that all the names used for extraction should already have been + registered. + + We take the definition of the forward translation as parameter (which is + equal to the definition to extract, if we extract a forward function) because + it is useful for the decrease clause. + *) +let extract_fun_decl (ctx : extraction_ctx) (fmt : F.formatter) + (qualif : fun_decl_qualif) (has_decreases_clause : bool) (def : fun_decl) : + unit = + assert (not def.is_global_decl_body); + (* Retrieve the function name *) + let def_name = ctx_get_local_function def.def_id def.back_id ctx in + (* (* Add the type parameters - note that we need those bindings only for the + * body translation (they are not top-level) *) + let ctx, _ = ctx_add_type_params def.signature.type_params ctx in *) + (* Add a break before *) + F.pp_print_break fmt 0 0; + (* Print a comment to link the extracted type to its original rust definition *) + F.pp_print_string fmt + ("(** [" ^ Print.fun_name_to_string def.basename ^ "] *)"); + F.pp_print_space fmt (); + (* Open a box for the definition, so that whenever possible it gets printed on + * one line *) + F.pp_open_hvbox fmt ctx.indent_incr; + (* Open a box for "let FUN_NAME (PARAMS) : EFFECT =" *) + F.pp_open_hovbox fmt ctx.indent_incr; + (* > "let FUN_NAME" *) + let is_opaque = Option.is_none def.body in + let qualif = fun_decl_qualif_keyword qualif in + F.pp_print_string fmt (qualif ^ " " ^ def_name); + F.pp_print_space fmt (); + (* Open a box for "(PARAMS) : EFFECT =" *) + F.pp_open_hvbox fmt 0; + (* Open a box for "(PARAMS)" *) + F.pp_open_hovbox fmt 0; + let ctx, ctx_body = extract_fun_parameters ctx fmt def in + (* Close the box for "(PARAMS)" *) + F.pp_close_box fmt (); + (* Print the return type - note that we have to be careful when + * printing the input values for the decrease clause, because + * it introduces bindings in the context... We thus "forget" + * the bindings we introduced above. + * TODO: figure out a cleaner way *) + let _ = + F.pp_print_string fmt ":"; + F.pp_print_space fmt (); + (* Open a box for the EFFECT *) + F.pp_open_hvbox fmt 0; + (* Open a box for the return type *) + F.pp_open_hovbox fmt ctx.indent_incr; + (* Print the return type *) + (* For opaque definitions, as we don't have named parameters under the hand, + * we don't print parameters in the form [(x : a) (y : b) ...] above, + * but wait until here to print the types: [a -> b -> ...]. *) + if is_opaque then extract_fun_input_parameters_types ctx fmt def; + (* [Tot] *) + if has_decreases_clause then ( + F.pp_print_string fmt "Tot"; + F.pp_print_space fmt ()); + extract_ty ctx fmt has_decreases_clause def.signature.output; + (* Close the box for the return type *) + F.pp_close_box fmt (); + (* Print the decrease clause - rk.: a function with a decreases clause + * is necessarily a transparent function *) + if has_decreases_clause then ( + F.pp_print_space fmt (); + (* Open a box for the decrease clause *) + F.pp_open_hovbox fmt 0; + (* *) + F.pp_print_string fmt "(decreases"; + F.pp_print_space fmt (); + F.pp_print_string fmt "("; + (* The name of the decrease clause *) + let decr_name = ctx_get_decreases_clause def.def_id ctx in + F.pp_print_string fmt decr_name; + (* Print the type parameters *) + List.iter + (fun (p : type_var) -> + let pname = ctx_get_type_var p.index ctx in + F.pp_print_space fmt (); + F.pp_print_string fmt pname) + def.signature.type_params; + (* Print the input values: we have to be careful here to print + * only the input values which are in common with the *forward* + * function (the additional input values "given back" to the + * backward functions have no influence on termination: we thus + * share the decrease clauses between the forward and the backward + * functions). + *) + let inputs_lvs = + let all_inputs = (Option.get def.body).inputs_lvs in + (* We have to count: + * - the forward inputs + * - the state + *) + let num_fwd_inputs = def.signature.info.num_fwd_inputs in + let num_fwd_inputs = + if def.signature.info.effect_info.input_state then 1 + num_fwd_inputs + else num_fwd_inputs + in + Collections.List.prefix num_fwd_inputs all_inputs + in + let _ = + List.fold_left + (fun ctx (lv : typed_pattern) -> + F.pp_print_space fmt (); + let ctx = extract_typed_pattern ctx fmt false lv in + ctx) + ctx inputs_lvs + in + F.pp_print_string fmt "))"; + (* Close the box for the decrease clause *) + F.pp_close_box fmt ()); + (* Close the box for the EFFECT *) + F.pp_close_box fmt () + in + (* Print the "=" *) + if not is_opaque then ( + F.pp_print_space fmt (); + F.pp_print_string fmt "="); + (* Close the box for "(PARAMS) : EFFECT =" *) + F.pp_close_box fmt (); + (* Close the box for "let FUN_NAME (PARAMS) : EFFECT =" *) + F.pp_close_box fmt (); + if not is_opaque then ( + F.pp_print_space fmt (); + (* Open a box for the body *) + F.pp_open_hvbox fmt 0; + (* Extract the body *) + let _ = extract_texpression ctx_body fmt false (Option.get def.body).body in + (* Close the box for the body *) + F.pp_close_box fmt ()); + (* Close the box for the definition *) + F.pp_close_box fmt (); + (* Add breaks to insert new lines between definitions *) + F.pp_print_break fmt 0 0 + +(** Extract a global declaration body of the shape "QUALIF NAME : TYPE = BODY" with a custom body extractor *) +let extract_global_decl_body (ctx : extraction_ctx) (fmt : F.formatter) + (qualif : fun_decl_qualif) (name : string) (ty : ty) + (extract_body : (F.formatter -> unit) Option.t) : unit = + let is_opaque = Option.is_none extract_body in + + (* Open the definition box (depth=0) *) + F.pp_open_hvbox fmt ctx.indent_incr; + + (* Open "QUALIF NAME : TYPE =" box (depth=1) *) + F.pp_open_hovbox fmt ctx.indent_incr; + (* Print "QUALIF NAME " *) + F.pp_print_string fmt (fun_decl_qualif_keyword qualif ^ " " ^ name); + F.pp_print_space fmt (); + + (* Open ": TYPE =" box (depth=2) *) + F.pp_open_hvbox fmt 0; + (* Print ": " *) + F.pp_print_string fmt ":"; + F.pp_print_space fmt (); + + (* Open "TYPE" box (depth=3) *) + F.pp_open_hovbox fmt ctx.indent_incr; + (* Print "TYPE" *) + extract_ty ctx fmt false ty; + (* Close "TYPE" box (depth=3) *) + F.pp_close_box fmt (); + + if not is_opaque then ( + (* Print " =" *) + F.pp_print_space fmt (); + F.pp_print_string fmt "="); + (* Close ": TYPE =" box (depth=2) *) + F.pp_close_box fmt (); + (* Close "QUALIF NAME : TYPE =" box (depth=1) *) + F.pp_close_box fmt (); + + if not is_opaque then ( + F.pp_print_space fmt (); + (* Open "BODY" box (depth=1) *) + F.pp_open_hvbox fmt 0; + (* Print "BODY" *) + (Option.get extract_body) fmt; + (* Close "BODY" box (depth=1) *) + F.pp_close_box fmt ()); + (* Close the definition box (depth=0) *) + F.pp_close_box fmt () + +(** Extract a global declaration. + We generate the body which computes the global value separately from the value declaration itself. + + For example in Rust, + [static X: u32 = 3;] + + will be translated to: + [let x_body : result u32 = Return 3] + [let x_c : u32 = eval_global x_body] + *) +let extract_global_decl (ctx : extraction_ctx) (fmt : F.formatter) + (global : A.global_decl) (body : fun_decl) (interface : bool) : unit = + assert body.is_global_decl_body; + assert (Option.is_none body.back_id); + assert (List.length body.signature.inputs = 0); + assert (List.length body.signature.doutputs = 1); + assert (List.length body.signature.type_params = 0); + + (* Add a break then the name of the corresponding LLBC declaration *) + F.pp_print_break fmt 0 0; + F.pp_print_string fmt + ("(** [" ^ Print.global_name_to_string global.name ^ "] *)"); + F.pp_print_space fmt (); + + let decl_name = ctx_get_global global.def_id ctx in + let body_name = ctx_get_function (Regular global.body_id) None ctx in + + let decl_ty, body_ty = + let ty = body.signature.output in + if body.signature.info.effect_info.can_fail then (unwrap_result_ty ty, ty) + else (ty, mk_result_ty ty) + in + match body.body with + | None -> + let qualif = if interface then Val else AssumeVal in + extract_global_decl_body ctx fmt qualif decl_name decl_ty None + | Some body -> + extract_global_decl_body ctx fmt Let body_name body_ty + (Some (fun fmt -> extract_texpression ctx fmt false body.body)); + F.pp_print_break fmt 0 0; + extract_global_decl_body ctx fmt Let decl_name decl_ty + (Some (fun fmt -> F.pp_print_string fmt ("eval_global " ^ body_name))); + F.pp_print_break fmt 0 0 + +(** Extract a unit test, if the function is a unit function (takes no + parameters, returns unit). + + A unit test simply checks that the function normalizes to [Return ()]: + {[ + let _ = assert_norm (FUNCTION () = Return ()) + ]} + *) +let extract_unit_test_if_unit_fun (ctx : extraction_ctx) (fmt : F.formatter) + (def : fun_decl) : unit = + (* We only insert unit tests for forward functions *) + assert (def.back_id = None); + (* Check if this is a unit function *) + let sg = def.signature in + if + sg.type_params = [] + && (sg.inputs = [ mk_unit_ty ] || sg.inputs = []) + && sg.output = mk_result_ty mk_unit_ty + then ( + (* Add a break before *) + F.pp_print_break fmt 0 0; + (* Print a comment *) + F.pp_print_string fmt + ("(** Unit test for [" ^ Print.fun_name_to_string def.basename ^ "] *)"); + F.pp_print_space fmt (); + (* Open a box for the test *) + F.pp_open_hovbox fmt ctx.indent_incr; + (* Print the test *) + F.pp_print_string fmt "let _ ="; + F.pp_print_space fmt (); + F.pp_print_string fmt "assert_norm"; + F.pp_print_space fmt (); + F.pp_print_string fmt "("; + let fun_name = ctx_get_local_function def.def_id def.back_id ctx in + F.pp_print_string fmt fun_name; + if sg.inputs <> [] then ( + F.pp_print_space fmt (); + F.pp_print_string fmt "()"); + F.pp_print_space fmt (); + F.pp_print_string fmt "="; + F.pp_print_space fmt (); + let success = ctx_get_variant (Assumed Result) result_return_id ctx in + F.pp_print_string fmt (success ^ " ())"); + (* Close the box for the test *) + F.pp_close_box fmt (); + (* Add a break after *) + F.pp_print_break fmt 0 0) + else (* Do nothing *) + () diff --git a/compiler/FunsAnalysis.ml b/compiler/FunsAnalysis.ml new file mode 100644 index 00000000..248ad8b3 --- /dev/null +++ b/compiler/FunsAnalysis.ml @@ -0,0 +1,143 @@ +(** Compute various information, including: + - can a function fail (by having `Fail` in its body, or transitively + calling a function which can fail - this is false for globals) + - can a function diverge (by being recursive, containing a loop or + transitively calling a function which can diverge) + - does a function perform stateful operations (i.e., do we need a state + to translate it) + *) + +open LlbcAst +open Crates +module EU = ExpressionsUtils + +type fun_info = { + can_fail : bool; + (* Not used yet: all the extracted functions use an error monad *) + stateful : bool; + divergent : bool; (* Not used yet *) +} +[@@deriving show] +(** Various information about a function. + + Note that not all this information is used yet to adjust the extraction yet. + *) + +type modules_funs_info = fun_info FunDeclId.Map.t +(** Various information about a module's functions *) + +let analyze_module (m : llbc_crate) (funs_map : fun_decl FunDeclId.Map.t) + (globals_map : global_decl GlobalDeclId.Map.t) (use_state : bool) : + modules_funs_info = + let infos = ref FunDeclId.Map.empty in + + let register_info (id : FunDeclId.id) (info : fun_info) : unit = + assert (not (FunDeclId.Map.mem id !infos)); + infos := FunDeclId.Map.add id info !infos + in + + (* Analyze a group of mutually recursive functions. + * As the functions can call each other, we compute the same information + * for all of them (if one of the functions can fail, then all of them + * can fail, etc.). + * + * We simply check if the functions contains panic statements, loop statements, + * recursive calls, etc. We use the previously computed information in case + * of function calls. + *) + let analyze_fun_decls (fun_ids : FunDeclId.Set.t) (d : fun_decl list) : + fun_info = + let can_fail = ref false in + let stateful = ref false in + let divergent = ref false in + + let visit_fun (f : fun_decl) : unit = + let obj = + object (self) + inherit [_] iter_statement as super + method may_fail b = can_fail := !can_fail || b + + method! visit_Assert env a = + self#may_fail true; + super#visit_Assert env a + + method! visit_rvalue _env rv = + match rv with + | Use _ | Ref _ | Discriminant _ | Aggregate _ -> () + | UnaryOp (uop, _) -> can_fail := EU.unop_can_fail uop || !can_fail + | BinaryOp (bop, _, _) -> + can_fail := EU.binop_can_fail bop || !can_fail + + method! visit_Call env call = + (match call.func with + | Regular id -> + if FunDeclId.Set.mem id fun_ids then divergent := true + else + let info = FunDeclId.Map.find id !infos in + self#may_fail info.can_fail; + stateful := !stateful || info.stateful; + divergent := !divergent || info.divergent + | Assumed id -> + (* None of the assumed functions is stateful for now *) + can_fail := !can_fail || Assumed.assumed_can_fail id); + super#visit_Call env call + + method! visit_Panic env = + self#may_fail true; + super#visit_Panic env + + method! visit_Loop env loop = + divergent := true; + super#visit_Loop env loop + end + in + (* Sanity check: global bodies don't contain stateful calls *) + assert ((not f.is_global_decl_body) || not !stateful); + match f.body with + | None -> + (* Opaque function: we consider they fail by default *) + obj#may_fail true; + stateful := (not f.is_global_decl_body) && use_state + | Some body -> obj#visit_statement () body.body + in + List.iter visit_fun d; + (* We need to know if the declaration group contains a global - note that + * groups containing globals contain exactly one declaration *) + let is_global_decl_body = List.exists (fun f -> f.is_global_decl_body) d in + assert ((not is_global_decl_body) || List.length d == 1); + (* We ignore on purpose functions that cannot fail and consider they *can* + * fail: the result of the analysis is not used yet to adjust the translation + * so that the functions which syntactically can't fail don't use an error monad. + * However, we do keep the result of the analysis for global bodies. + * *) + can_fail := (not is_global_decl_body) || !can_fail; + { can_fail = !can_fail; stateful = !stateful; divergent = !divergent } + in + + let analyze_fun_decl_group (d : fun_declaration_group) : unit = + (* Retrieve the function declarations *) + let funs = match d with NonRec id -> [ id ] | Rec ids -> ids in + let funs = List.map (fun id -> FunDeclId.Map.find id funs_map) funs in + let fun_ids = List.map (fun (d : fun_decl) -> d.def_id) funs in + let fun_ids = FunDeclId.Set.of_list fun_ids in + let info = analyze_fun_decls fun_ids funs in + List.iter (fun (f : fun_decl) -> register_info f.def_id info) funs + in + + let rec analyze_decl_groups (decls : declaration_group list) : unit = + match decls with + | [] -> () + | Type _ :: decls' -> analyze_decl_groups decls' + | Fun decl :: decls' -> + analyze_fun_decl_group decl; + analyze_decl_groups decls' + | Global id :: decls' -> + (* Analyze a global by analyzing its body function *) + let global = GlobalDeclId.Map.find id globals_map in + analyze_fun_decl_group (NonRec global.body_id); + analyze_decl_groups decls' + in + + analyze_decl_groups m.declarations; + + !infos diff --git a/compiler/Identifiers.ml b/compiler/Identifiers.ml new file mode 100644 index 00000000..b022b18d --- /dev/null +++ b/compiler/Identifiers.ml @@ -0,0 +1,139 @@ +module C = Collections + +(** Signature for a module describing an identifier. + + We often need identifiers (for definitions, variables, etc.) and in + order to make sure we don't mix them, we use a generative functor + (see {!IdGen}). +*) +module type Id = sig + type id + + (** Id generator - simply a counter *) + type generator + + val zero : id + val generator_zero : generator + val generator_from_incr_id : id -> generator + val fresh_stateful_generator : unit -> generator ref * (unit -> id) + val mk_stateful_generator : generator -> generator ref * (unit -> id) + val incr : id -> id + + (* TODO: this should be stateful! - but we may want to be able to duplicate + contexts... + Maybe we could have a [fresh] and a [global_fresh] + TODO: change the order of the returned types + *) + val fresh : generator -> id * generator + val to_string : id -> string + val pp_id : Format.formatter -> id -> unit + val show_id : id -> string + val id_of_json : Yojson.Basic.t -> (id, string) result + val compare_id : id -> id -> int + val max : id -> id -> id + val min : id -> id -> id + val pp_generator : Format.formatter -> generator -> unit + val show_generator : generator -> string + val to_int : id -> int + val of_int : int -> id + val nth : 'a list -> id -> 'a + (* TODO: change the signature (invert the index and the list *) + + val nth_opt : 'a list -> id -> 'a option + + (** Update the nth element of the list. + + Raises [Invalid_argument] if the identifier is out of range. + *) + val update_nth : 'a list -> id -> 'a -> 'a list + + val mapi : (id -> 'a -> 'b) -> 'a list -> 'b list + + (** Same as {!mapi}, but where the indices start with 1. + + TODO: generalize to [map_from_i] + *) + val mapi_from1 : (id -> 'a -> 'b) -> 'a list -> 'b list + + val iteri : (id -> 'a -> unit) -> 'a list -> unit + + module Ord : C.OrderedType with type t = id + module Set : C.Set with type elt = id + module Map : C.Map with type key = id +end + +(** Generative functor for identifiers. + + See {!Id}. +*) +module IdGen () : Id = struct + (* TODO: use Z.t *) + type id = int [@@deriving show] + type generator = id [@@deriving show] + + let zero = 0 + let generator_zero = 0 + + let incr x = + (* Identifiers should never overflow (because max_int is a really big + * value - but we really want to make sure we detect overflows if + * they happen *) + if x = max_int then raise (Errors.IntegerOverflow ()) else x + 1 + + let generator_from_incr_id id = incr id + + let mk_stateful_generator g = + let g = ref g in + let fresh () = + let id = !g in + g := incr id; + id + in + (g, fresh) + + let fresh_stateful_generator () = mk_stateful_generator 0 + let fresh gen = (gen, incr gen) + let to_string = string_of_int + let to_int x = x + let of_int x = x + + let id_of_json js = + (* TODO: check boundaries ? *) + match js with + | `Int i -> Ok i + | _ -> Error ("id_of_json: failed on " ^ Yojson.Basic.show js) + + let compare_id = compare + let max id0 id1 = if id0 > id1 then id0 else id1 + let min id0 id1 = if id0 < id1 then id0 else id1 + let nth v id = List.nth v id + let nth_opt v id = List.nth_opt v id + + let rec update_nth vec id v = + match (vec, id) with + | [], _ -> raise (Invalid_argument "Out of range") + | _ :: vec', 0 -> v :: vec' + | x :: vec', _ -> x :: update_nth vec' (id - 1) v + + let mapi = List.mapi + + let mapi_from1 f ls = + let rec aux i ls = + match ls with [] -> [] | x :: ls' -> f i x :: aux (i + 1) ls' + in + aux 1 ls + + let iteri = List.iteri + + module Ord = struct + type t = id + + let compare = compare + let to_string = to_string + let pp_t = pp_id + let show_t = show_id + end + + module Set = C.MakeSet (Ord) + module Map = C.MakeMap (Ord) +end diff --git a/compiler/Interpreter.ml b/compiler/Interpreter.ml new file mode 100644 index 00000000..7f51c5b9 --- /dev/null +++ b/compiler/Interpreter.ml @@ -0,0 +1,396 @@ +open Cps +open InterpreterUtils +open InterpreterProjectors +open InterpreterBorrows +open InterpreterStatements +open LlbcAstUtils +module L = Logging +module T = Types +module A = LlbcAst +module SA = SymbolicAst + +(** The local logger *) +let log = L.interpreter_log + +let compute_type_fun_global_contexts (m : Crates.llbc_crate) : + C.type_context * C.fun_context * C.global_context = + let type_decls_list, _, _ = Crates.split_declarations m.declarations in + let type_decls, fun_decls, global_decls = Crates.compute_defs_maps m in + let type_decls_groups, _funs_defs_groups, _globals_defs_groups = + Crates.split_declarations_to_group_maps m.declarations + in + let type_infos = + TypesAnalysis.analyze_type_declarations type_decls type_decls_list + in + let type_context = { C.type_decls_groups; type_decls; type_infos } in + let fun_context = { C.fun_decls } in + let global_context = { C.global_decls } in + (type_context, fun_context, global_context) + +let initialize_eval_context (type_context : C.type_context) + (fun_context : C.fun_context) (global_context : C.global_context) + (type_vars : T.type_var list) : C.eval_ctx = + C.reset_global_counters (); + { + C.type_context; + C.fun_context; + C.global_context; + C.type_vars; + C.env = [ C.Frame ]; + C.ended_regions = T.RegionId.Set.empty; + } + +(** Initialize an evaluation context to execute a function. + + Introduces local variables initialized in the following manner: + - input arguments are initialized as symbolic values + - the remaining locals are initialized as [⊥] + Abstractions are introduced for the regions present in the function + signature. + + We return: + - the initialized evaluation context + - the list of symbolic values introduced for the input values + - the instantiated function signature + *) +let initialize_symbolic_context_for_fun (type_context : C.type_context) + (fun_context : C.fun_context) (global_context : C.global_context) + (fdef : A.fun_decl) : C.eval_ctx * V.symbolic_value list * A.inst_fun_sig = + (* The abstractions are not initialized the same way as for function + * calls: they contain *loan* projectors, because they "provide" us + * with the input values (which behave as if they had been returned + * by some function calls...). + * Also, note that we properly set the set of parents of every abstraction: + * this should not be necessary, as those abstractions should never be + * *automatically* ended (because ending some borrows requires to end + * one of them), but rather selectively ended when generating code + * for each of the backward functions. We do it only because we can + * do it, and because it gives a bit of sanity. + * *) + let sg = fdef.signature in + (* Create the context *) + let ctx = + initialize_eval_context type_context fun_context global_context + sg.type_params + in + (* Instantiate the signature *) + let type_params = List.map (fun tv -> T.TypeVar tv.T.index) sg.type_params in + let inst_sg = instantiate_fun_sig type_params sg in + (* Create fresh symbolic values for the inputs *) + let input_svs = + List.map (fun ty -> mk_fresh_symbolic_value V.SynthInput ty) inst_sg.inputs + in + (* Initialize the abstractions as empty (i.e., with no avalues) abstractions *) + let call_id = C.fresh_fun_call_id () in + assert (call_id = V.FunCallId.zero); + let compute_abs_avalues (abs : V.abs) (ctx : C.eval_ctx) : + C.eval_ctx * V.typed_avalue list = + (* Project over the values - we use *loan* projectors, as explained above *) + let avalues = + List.map (mk_aproj_loans_value_from_symbolic_value abs.regions) input_svs + in + (ctx, avalues) + in + let region_can_end _ = true in + let ctx = + create_push_abstractions_from_abs_region_groups call_id V.SynthInput + inst_sg.A.regions_hierarchy region_can_end compute_abs_avalues ctx + in + (* Split the variables between return var, inputs and remaining locals *) + let body = Option.get fdef.body in + let ret_var = List.hd body.locals in + let input_vars, local_vars = + Collections.List.split_at (List.tl body.locals) body.arg_count + in + (* Push the return variable (initialized with ⊥) *) + let ctx = C.ctx_push_uninitialized_var ctx ret_var in + (* Push the input variables (initialized with symbolic values) *) + let input_values = List.map mk_typed_value_from_symbolic_value input_svs in + let ctx = C.ctx_push_vars ctx (List.combine input_vars input_values) in + (* Push the remaining local variables (initialized with ⊥) *) + let ctx = C.ctx_push_uninitialized_vars ctx local_vars in + (* Return *) + (ctx, input_svs, inst_sg) + +(** Small helper. + + This is a continuation function called by the symbolic interpreter upon + reaching the [return] instruction when synthesizing a *backward* function: + this continuation takes care of doing the proper manipulations to finish + the synthesis (mostly by ending abstractions). +*) +let evaluate_function_symbolic_synthesize_backward_from_return + (config : C.config) (fdef : A.fun_decl) (inst_sg : A.inst_fun_sig) + (back_id : T.RegionGroupId.id) (ctx : C.eval_ctx) : SA.expression option = + (* We need to instantiate the function signature - to retrieve + * the return type. Note that it is important to re-generate + * an instantiation of the signature, so that we use fresh + * region ids for the return abstractions. *) + let sg = fdef.signature in + let type_params = List.map (fun tv -> T.TypeVar tv.T.index) sg.type_params in + let ret_inst_sg = instantiate_fun_sig type_params sg in + let ret_rty = ret_inst_sg.output in + (* Move the return value out of the return variable *) + let cf_pop_frame = ctx_pop_frame config in + + (* We need to find the parents regions/abstractions of the region we + * will end - this will allow us to, first, mark the other return + * regions as non-endable, and, second, end those parent regions in + * proper order. *) + let parent_rgs = list_parent_region_groups sg back_id in + let parent_input_abs_ids = + T.RegionGroupId.mapi + (fun rg_id rg -> + if T.RegionGroupId.Set.mem rg_id parent_rgs then Some rg.T.id else None) + inst_sg.regions_hierarchy + in + let parent_input_abs_ids = + List.filter_map (fun x -> x) parent_input_abs_ids + in + + (* Insert the return value in the return abstractions (by applying + * borrow projections) *) + let cf_consume_ret ret_value ctx = + let ret_call_id = C.fresh_fun_call_id () in + let compute_abs_avalues (abs : V.abs) (ctx : C.eval_ctx) : + C.eval_ctx * V.typed_avalue list = + let ctx, avalue = + apply_proj_borrows_on_input_value config ctx abs.regions + abs.ancestors_regions ret_value ret_rty + in + (ctx, [ avalue ]) + in + + (* Initialize and insert the abstractions in the context. + * + * We take care of disallowing ending the return regions which we + * shouldn't end (see the documentation of the [can_end] field of [abs] + * for more information. *) + let parent_and_current_rgs = T.RegionGroupId.Set.add back_id parent_rgs in + let region_can_end rid = + T.RegionGroupId.Set.mem rid parent_and_current_rgs + in + assert (region_can_end back_id); + let ctx = + create_push_abstractions_from_abs_region_groups ret_call_id V.SynthRet + ret_inst_sg.A.regions_hierarchy region_can_end compute_abs_avalues ctx + in + + (* We now need to end the proper *input* abstractions - pay attention + * to the fact that we end the *input* abstractions, not the *return* + * abstractions (of course, the corresponding return abstractions will + * automatically be ended, because they consumed values coming from the + * input abstractions...) *) + (* End the parent abstractions and the current abstraction - note that we + * end them in an order which follows the regions hierarchy: it should lead + * to generated code which has a better consistency between the parent + * and children backward functions *) + let current_abs_id = + (T.RegionGroupId.nth inst_sg.regions_hierarchy back_id).id + in + let target_abs_ids = List.append parent_input_abs_ids [ current_abs_id ] in + let cf_end_target_abs cf = + List.fold_left + (fun cf id -> end_abstraction config [] id cf) + cf target_abs_ids + in + (* Generate the Return node *) + let cf_return : m_fun = fun _ -> Some (SA.Return None) in + (* Apply *) + cf_end_target_abs cf_return ctx + in + cf_pop_frame cf_consume_ret ctx + +(** Evaluate a function with the symbolic interpreter. + + We return: + - the list of symbolic values introduced for the input values (this is useful + for the synthesis) + - the symbolic AST generated by the symbolic execution + *) +let evaluate_function_symbolic (config : C.partial_config) (synthesize : bool) + (type_context : C.type_context) (fun_context : C.fun_context) + (global_context : C.global_context) (fdef : A.fun_decl) + (back_id : T.RegionGroupId.id option) : + V.symbolic_value list * SA.expression option = + (* Debug *) + let name_to_string () = + Print.fun_name_to_string fdef.A.name + ^ " (" + ^ Print.option_to_string T.RegionGroupId.to_string back_id + ^ ")" + in + log#ldebug (lazy ("evaluate_function_symbolic: " ^ name_to_string ())); + + (* Create the evaluation context *) + let ctx, input_svs, inst_sg = + initialize_symbolic_context_for_fun type_context fun_context global_context + fdef + in + + (* Create the continuation to finish the evaluation *) + let config = C.config_of_partial C.SymbolicMode config in + let cf_finish res ctx = + match res with + | Return -> + if synthesize then + (* There are two cases: + * - if this is a forward translation, we retrieve the returned value. + * - if this is a backward translation, we introduce "return" + * abstractions to consume the return value, then end all the + * abstractions up to the one in which we are interested. + *) + match back_id with + | None -> + (* Forward translation *) + (* Pop the frame and retrieve the returned value at the same time*) + let cf_pop = ctx_pop_frame config in + (* Generate the Return node *) + let cf_return ret_value : m_fun = + fun _ -> Some (SA.Return (Some ret_value)) + in + (* Apply *) + cf_pop cf_return ctx + | Some back_id -> + (* Backward translation *) + evaluate_function_symbolic_synthesize_backward_from_return config + fdef inst_sg back_id ctx + else None + | Panic -> + (* Note that as we explore all the execution branches, one of + * the executions can lead to a panic *) + if synthesize then Some SA.Panic else None + | _ -> + failwith ("evaluate_function_symbolic failed on: " ^ name_to_string ()) + in + + (* Evaluate the function *) + let symbolic = + eval_function_body config (Option.get fdef.A.body).body cf_finish ctx + in + + (* Return *) + (input_svs, symbolic) + +module Test = struct + (** Test a unit function (taking no arguments) by evaluating it in an empty + environment. + *) + let test_unit_function (config : C.partial_config) (crate : Crates.llbc_crate) + (fid : A.FunDeclId.id) : unit = + (* Retrieve the function declaration *) + let fdef = A.FunDeclId.nth crate.functions fid in + let body = Option.get fdef.body in + + (* Debug *) + log#ldebug + (lazy ("test_unit_function: " ^ Print.fun_name_to_string fdef.A.name)); + + (* Sanity check - *) + assert (List.length fdef.A.signature.region_params = 0); + assert (List.length fdef.A.signature.type_params = 0); + assert (body.A.arg_count = 0); + + (* Create the evaluation context *) + let type_context, fun_context, global_context = + compute_type_fun_global_contexts crate + in + let ctx = + initialize_eval_context type_context fun_context global_context [] + in + + (* Insert the (uninitialized) local variables *) + let ctx = C.ctx_push_uninitialized_vars ctx body.A.locals in + + (* Create the continuation to check the function's result *) + let config = C.config_of_partial C.ConcreteMode config in + let cf_check res ctx = + match res with + | Return -> + (* Ok: drop the local variables and finish *) + ctx_pop_frame config (fun _ _ -> None) ctx + | _ -> + failwith + ("Unit test failed (concrete execution) on: " + ^ Print.fun_name_to_string fdef.A.name) + in + + (* Evaluate the function *) + let _ = eval_function_body config body.body cf_check ctx in + () + + (** Small helper: return true if the function is a *transparent* unit function + (no parameters, no arguments) - TODO: move *) + let fun_decl_is_transparent_unit (def : A.fun_decl) : bool = + match def.body with + | None -> false + | Some body -> + body.arg_count = 0 + && List.length def.A.signature.region_params = 0 + && List.length def.A.signature.type_params = 0 + && List.length def.A.signature.inputs = 0 + + (** Test all the unit functions in a list of function definitions *) + let test_unit_functions (config : C.partial_config) + (crate : Crates.llbc_crate) : unit = + let unit_funs = List.filter fun_decl_is_transparent_unit crate.functions in + let test_unit_fun (def : A.fun_decl) : unit = + test_unit_function config crate def.A.def_id + in + List.iter test_unit_fun unit_funs + + (** Execute the symbolic interpreter on a function. *) + let test_function_symbolic (config : C.partial_config) (synthesize : bool) + (type_context : C.type_context) (fun_context : C.fun_context) + (global_context : C.global_context) (fdef : A.fun_decl) : unit = + (* Debug *) + log#ldebug + (lazy ("test_function_symbolic: " ^ Print.fun_name_to_string fdef.A.name)); + + (* Evaluate *) + let evaluate = + evaluate_function_symbolic config synthesize type_context fun_context + global_context fdef + in + (* Execute the forward function *) + let _ = evaluate None in + (* Execute the backward functions *) + let _ = + T.RegionGroupId.mapi + (fun gid _ -> evaluate (Some gid)) + fdef.signature.regions_hierarchy + in + + () + + (** Small helper *) + let fun_decl_is_transparent (def : A.fun_decl) : bool = + Option.is_some def.body + + (** Execute the symbolic interpreter on a list of functions. + + TODO: for now we ignore the functions which contain loops, because + they are not supported by the symbolic interpreter. + *) + let test_functions_symbolic (config : C.partial_config) (synthesize : bool) + (crate : Crates.llbc_crate) : unit = + (* Filter the functions which contain loops *) + let no_loop_funs = + List.filter + (fun f -> not (LlbcAstUtils.fun_decl_has_loops f)) + crate.functions + in + (* Filter the opaque functions *) + let no_loop_funs = List.filter fun_decl_is_transparent no_loop_funs in + let type_context, fun_context, global_context = + compute_type_fun_global_contexts crate + in + let test_fun (def : A.fun_decl) : unit = + (* Execute the function - note that as the symbolic interpreter explores + * all the path, some executions are expected to "panic": we thus don't + * check the return value *) + test_function_symbolic config synthesize type_context fun_context + global_context def + in + List.iter test_fun no_loop_funs +end diff --git a/compiler/InterpreterBorrows.ml b/compiler/InterpreterBorrows.ml new file mode 100644 index 00000000..30c3b221 --- /dev/null +++ b/compiler/InterpreterBorrows.ml @@ -0,0 +1,1580 @@ +module T = Types +module V = Values +module C = Contexts +module Subst = Substitute +module L = Logging +module S = SynthesizeSymbolic +open Cps +open ValuesUtils +open TypesUtils +open InterpreterUtils +open InterpreterBorrowsCore +open InterpreterProjectors + +(** The local logger *) +let log = InterpreterBorrowsCore.log + +(** Auxiliary function to end borrows: lookup a borrow in the environment, + update it (by returning an updated environment where the borrow has been + replaced by {!V.Bottom})) if we can end the borrow (for instance, it is not + an outer borrow...) or return the reason why we couldn't update the borrow. + + [end_borrow] then simply performs a loop: as long as we need to end (outer) + borrows, we end them, before finally ending the borrow we wanted to end in the + first place. + + Note that it is possible to end a borrow in an abstraction, without ending + the whole abstraction, if the corresponding loan is inside the abstraction + as well. The [allowed_abs] parameter controls whether we allow to end borrows + in an abstraction or not, and in which abstraction. +*) +let end_borrow_get_borrow (allowed_abs : V.AbstractionId.id option) + (l : V.BorrowId.id) (ctx : C.eval_ctx) : + (C.eval_ctx * g_borrow_content option, priority_borrows_or_abs) result = + (* We use a reference to communicate the kind of borrow we found, if we + * find one *) + let replaced_bc : g_borrow_content option ref = ref None in + let set_replaced_bc (bc : g_borrow_content) = + assert (Option.is_none !replaced_bc); + replaced_bc := Some bc + in + (* Raise an exception if: + * - there are outer borrows + * - if we are inside an abstraction + * - there are inner loans + * this exception is caught in a wrapper function *) + let raise_if_priority (outer : V.AbstractionId.id option * borrow_ids option) + (borrowed_value : V.typed_value option) = + (* First, look for outer borrows or abstraction *) + let outer_abs, outer_borrows = outer in + (match outer_abs with + | Some abs -> ( + if + (* Check if we can end borrows inside this abstraction *) + Some abs <> allowed_abs + then raise (FoundPriority (OuterAbs abs)) + else + match outer_borrows with + | Some borrows -> raise (FoundPriority (OuterBorrows borrows)) + | None -> ()) + | None -> ( + match outer_borrows with + | Some borrows -> raise (FoundPriority (OuterBorrows borrows)) + | None -> ())); + (* Then check if there are inner loans *) + match borrowed_value with + | None -> () + | Some v -> ( + match get_first_loan_in_value v with + | None -> () + | Some c -> ( + match c with + | V.SharedLoan (bids, _) -> + raise (FoundPriority (InnerLoans (Borrows bids))) + | V.MutLoan bid -> raise (FoundPriority (InnerLoans (Borrow bid))))) + in + + (* The environment is used to keep track of the outer loans *) + let obj = + object + inherit [_] C.map_eval_ctx as super + + (** We reimplement {!visit_Loan} because we may have to update the + outer borrows *) + method! visit_Loan (outer : V.AbstractionId.id option * borrow_ids option) + lc = + match lc with + | V.MutLoan bid -> V.Loan (super#visit_MutLoan outer bid) + | V.SharedLoan (bids, v) -> + (* Update the outer borrows before diving into the shared value *) + let outer = update_outer_borrows outer (Borrows bids) in + V.Loan (super#visit_SharedLoan outer bids v) + + method! visit_Borrow outer bc = + match bc with + | SharedBorrow (_, l') | InactivatedMutBorrow (_, l') -> + (* Check if this is the borrow we are looking for *) + if l = l' then ( + (* Check if there are outer borrows or if we are inside an abstraction *) + raise_if_priority outer None; + (* Register the update *) + set_replaced_bc (Concrete bc); + (* Update the value *) + V.Bottom) + else super#visit_Borrow outer bc + | V.MutBorrow (l', bv) -> + (* Check if this is the borrow we are looking for *) + if l = l' then ( + (* Check if there are outer borrows or if we are inside an abstraction *) + raise_if_priority outer (Some bv); + (* Register the update *) + set_replaced_bc (Concrete bc); + (* Update the value *) + V.Bottom) + else + (* Update the outer borrows before diving into the borrowed value *) + let outer = update_outer_borrows outer (Borrow l') in + V.Borrow (super#visit_MutBorrow outer l' bv) + + (** We reimplement {!visit_ALoan} because we may have to update the + outer borrows *) + method! visit_ALoan outer lc = + (* Note that the children avalues are just other, independent loans, + * so we don't need to update the outer borrows when diving in. + * We keep track of the parents/children relationship only because we + * need it to properly instantiate the backward functions when generating + * the pure translation. *) + match lc with + | V.AMutLoan (_, _) -> + (* Nothing special to do *) + super#visit_ALoan outer lc + | V.ASharedLoan (bids, v, av) -> + (* Explore the shared value - we need to update the outer borrows *) + let souter = update_outer_borrows outer (Borrows bids) in + let v = super#visit_typed_value souter v in + (* Explore the child avalue - we keep the same outer borrows *) + let av = super#visit_typed_avalue outer av in + (* Reconstruct *) + V.ALoan (V.ASharedLoan (bids, v, av)) + | V.AEndedMutLoan { given_back = _; child = _; given_back_meta = _ } + | V.AEndedSharedLoan _ + (* The loan has ended, so no need to update the outer borrows *) + | V.AIgnoredMutLoan _ (* Nothing special to do *) + | V.AEndedIgnoredMutLoan + { given_back = _; child = _; given_back_meta = _ } + (* Nothing special to do *) + | V.AIgnoredSharedLoan _ -> + (* Nothing special to do *) + super#visit_ALoan outer lc + + method! visit_ABorrow outer bc = + match bc with + | V.AMutBorrow (_, bid, _) -> + (* Check if this is the borrow we are looking for *) + if bid = l then ( + (* When ending a mut borrow, there are two cases: + * - in the general case, we have to end the whole abstraction + * (and thus raise an exception to signal that to the caller) + * - in some situations, the associated loan is inside the same + * abstraction as the borrow. In this situation, we can end + * the borrow without ending the whole abstraction, and we + * simply move the child avalue around. + *) + (* Check there are outer borrows, or if we need to end the whole + * abstraction *) + raise_if_priority outer None; + (* Register the update *) + set_replaced_bc (Abstract bc); + (* Update the value - note that we are necessarily in the second + * of the two cases described above. + * Also note that, as we are moving the borrowed value inside the + * abstraction (and not really giving the value back to the context) + * we do not insert {!AEndedMutBorrow} but rather {!ABottom} *) + V.ABottom) + else + (* Update the outer borrows before diving into the child avalue *) + let outer = update_outer_borrows outer (Borrow bid) in + super#visit_ABorrow outer bc + | V.ASharedBorrow bid -> + (* Check if this is the borrow we are looking for *) + if bid = l then ( + (* Check there are outer borrows, or if we need to end the whole + * abstraction *) + raise_if_priority outer None; + (* Register the update *) + set_replaced_bc (Abstract bc); + (* Update the value - note that we are necessarily in the second + * of the two cases described above *) + V.ABottom) + else super#visit_ABorrow outer bc + | V.AIgnoredMutBorrow (_, _) + | V.AEndedMutBorrow _ + | V.AEndedIgnoredMutBorrow + { given_back_loans_proj = _; child = _; given_back_meta = _ } + | V.AEndedSharedBorrow -> + (* Nothing special to do *) + super#visit_ABorrow outer bc + | V.AProjSharedBorrow asb -> + (* Check if the borrow we are looking for is in the asb *) + if borrow_in_asb l asb then ( + (* Check there are outer borrows, or if we need to end the whole + * abstraction *) + raise_if_priority outer None; + (* Register the update *) + set_replaced_bc (Abstract bc); + (* Update the value - note that we are necessarily in the second + * of the two cases described above *) + let asb = remove_borrow_from_asb l asb in + V.ABorrow (V.AProjSharedBorrow asb)) + else (* Nothing special to do *) + super#visit_ABorrow outer bc + + method! visit_abs outer abs = + (* Update the outer abs *) + let outer_abs, outer_borrows = outer in + assert (Option.is_none outer_abs); + assert (Option.is_none outer_borrows); + let outer = (Some abs.V.abs_id, None) in + super#visit_abs outer abs + end + in + (* Catch the exceptions - raised if there are outer borrows *) + try + let ctx = obj#visit_eval_ctx (None, None) ctx in + Ok (ctx, !replaced_bc) + with FoundPriority outers -> Error outers + +(** Auxiliary function to end borrows. See [give_back]. + + When we end a mutable borrow, we need to "give back" the value it contained + to its original owner by reinserting it at the proper position. + + Note that this function checks that there is exactly one loan to which we + give the value back. + TODO: this was not the case before, so some sanity checks are not useful anymore. + *) +let give_back_value (config : C.config) (bid : V.BorrowId.id) + (nv : V.typed_value) (ctx : C.eval_ctx) : C.eval_ctx = + (* Sanity check *) + assert (not (loans_in_value nv)); + assert (not (bottom_in_value ctx.ended_regions nv)); + (* Debug *) + log#ldebug + (lazy + ("give_back_value:\n- bid: " ^ V.BorrowId.to_string bid ^ "\n- value: " + ^ typed_value_to_string ctx nv + ^ "\n- context:\n" ^ eval_ctx_to_string ctx ^ "\n")); + (* We use a reference to check that we updated exactly one loan *) + let replaced : bool ref = ref false in + let set_replaced () = + assert (not !replaced); + replaced := true + in + (* Whenever giving back symbolic values, they shouldn't contain already ended regions *) + let check_symbolic_no_ended = true in + (* We sometimes need to reborrow values while giving a value back due: prepare that *) + let allow_reborrows = true in + let fresh_reborrow, apply_registered_reborrows = + prepare_reborrows config allow_reborrows + in + (* The visitor to give back the values *) + let obj = + object (self) + inherit [_] C.map_eval_ctx as super + + (** This is a bit annoying, but as we need the type of the value we + are exploring, for sanity checks, we need to implement + {!visit_typed_avalue} instead of + overriding {!visit_ALoan} *) + method! visit_typed_value opt_abs (v : V.typed_value) : V.typed_value = + match v.V.value with + | V.Loan lc -> + let value = self#visit_typed_Loan opt_abs v.V.ty lc in + ({ v with V.value } : V.typed_value) + | _ -> super#visit_typed_value opt_abs v + + method visit_typed_Loan opt_abs ty lc = + match lc with + | V.SharedLoan (bids, v) -> + (* We are giving back a value (i.e., the content of a *mutable* + * borrow): nothing special to do *) + V.Loan (super#visit_SharedLoan opt_abs bids v) + | V.MutLoan bid' -> + (* Check if this is the loan we are looking for *) + if bid' = bid then ( + (* Sanity check *) + let expected_ty = ty in + if nv.V.ty <> expected_ty then ( + log#serror + ("give_back_value: improper type:\n- expected: " + ^ ety_to_string ctx ty ^ "\n- received: " + ^ ety_to_string ctx nv.V.ty); + failwith "Value given back doesn't have the proper type"); + (* Replace *) + set_replaced (); + nv.V.value) + else V.Loan (super#visit_MutLoan opt_abs bid') + + (** This is a bit annoying, but as we need the type of the avalue we + are exploring, in order to be able to project the value we give + back, we need to reimplement {!visit_typed_avalue} instead of + {!visit_ALoan} *) + method! visit_typed_avalue opt_abs (av : V.typed_avalue) : V.typed_avalue + = + match av.V.value with + | V.ALoan lc -> + let value = self#visit_typed_ALoan opt_abs av.V.ty lc in + ({ av with V.value } : V.typed_avalue) + | _ -> super#visit_typed_avalue opt_abs av + + (** We need to inspect ignored mutable borrows, to insert loan projectors + if necessary. + *) + method! visit_ABorrow (opt_abs : V.abs option) (bc : V.aborrow_content) + : V.avalue = + match bc with + | V.AIgnoredMutBorrow (bid', child) -> + if bid' = Some bid then + (* Insert a loans projector - note that if this case happens, + * it is necessarily because we ended a parent abstraction, + * and the given back value is thus a symbolic value *) + match nv.V.value with + | V.Symbolic sv -> + let abs = Option.get opt_abs in + (* Remember the given back value as a meta-value + * TODO: it is a bit annoying to have to deconstruct + * the value... Think about a more elegant way. *) + let given_back_meta = as_symbolic nv.value in + (* The loan projector *) + let given_back_loans_proj = + mk_aproj_loans_value_from_symbolic_value abs.regions sv + in + (* Continue giving back in the child value *) + let child = super#visit_typed_avalue opt_abs child in + (* Return *) + V.ABorrow + (V.AEndedIgnoredMutBorrow + { given_back_loans_proj; child; given_back_meta }) + | _ -> failwith "Unreachable" + else + (* Continue exploring *) + V.ABorrow (super#visit_AIgnoredMutBorrow opt_abs bid' child) + | _ -> + (* Continue exploring *) + super#visit_ABorrow opt_abs bc + + (** We are not specializing an already existing method, but adding a + new method (for projections, we need type information) *) + method visit_typed_ALoan (opt_abs : V.abs option) (ty : T.rty) + (lc : V.aloan_content) : V.avalue = + (* Preparing a bit *) + let regions, ancestors_regions = + match opt_abs with + | None -> failwith "Unreachable" + | Some abs -> (abs.V.regions, abs.V.ancestors_regions) + in + (* Rk.: there is a small issue with the types of the aloan values. + * See the comment at the level of definition of {!typed_avalue} *) + let borrowed_value_aty = + let _, ty, _ = ty_get_ref ty in + ty + in + match lc with + | V.AMutLoan (bid', child) -> + if bid' = bid then ( + (* This is the loan we are looking for: apply the projection to + * the value we give back and replaced this mutable loan with + * an ended loan *) + (* Register the insertion *) + set_replaced (); + (* Remember the given back value as a meta-value *) + let given_back_meta = nv in + (* Apply the projection *) + let given_back = + apply_proj_borrows check_symbolic_no_ended ctx fresh_reborrow + regions ancestors_regions nv borrowed_value_aty + in + (* Continue giving back in the child value *) + let child = super#visit_typed_avalue opt_abs child in + (* Return the new value *) + V.ALoan (V.AEndedMutLoan { child; given_back; given_back_meta })) + else (* Continue exploring *) + super#visit_ALoan opt_abs lc + | V.ASharedLoan (_, _, _) -> + (* We are giving back a value to a *mutable* loan: nothing special to do *) + super#visit_ALoan opt_abs lc + | V.AEndedMutLoan { child = _; given_back = _; given_back_meta = _ } + | V.AEndedSharedLoan (_, _) -> + (* Nothing special to do *) + super#visit_ALoan opt_abs lc + | V.AIgnoredMutLoan (bid', child) -> + (* This loan is ignored, but we may have to project on a subvalue + * of the value which is given back *) + if bid' = bid then + (* Remember the given back value as a meta-value *) + let given_back_meta = nv in + (* Note that we replace the ignored mut loan by an *ended* ignored + * mut loan. Also, this is not the loan we are looking for *per se*: + * we don't register the fact that we inserted the value somewhere + * (i.e., we don't call {!set_replaced}) *) + let given_back = + apply_proj_borrows check_symbolic_no_ended ctx fresh_reborrow + regions ancestors_regions nv borrowed_value_aty + in + (* Continue giving back in the child value *) + let child = super#visit_typed_avalue opt_abs child in + V.ALoan + (V.AEndedIgnoredMutLoan { given_back; child; given_back_meta }) + else super#visit_ALoan opt_abs lc + | V.AEndedIgnoredMutLoan + { given_back = _; child = _; given_back_meta = _ } + | V.AIgnoredSharedLoan _ -> + (* Nothing special to do *) + super#visit_ALoan opt_abs lc + + method! visit_Abs opt_abs abs = + (* We remember in which abstraction we are before diving - + * this is necessary for projecting values: we need to know + * over which regions to project *) + assert (Option.is_none opt_abs); + super#visit_Abs (Some abs) abs + end + in + + (* Explore the environment *) + let ctx = obj#visit_eval_ctx None ctx in + (* Check we gave back to exactly one loan *) + assert !replaced; + (* Apply the reborrows *) + apply_registered_reborrows ctx + +(** Give back a *modified* symbolic value. *) +let give_back_symbolic_value (_config : C.config) + (proj_regions : T.RegionId.Set.t) (proj_ty : T.rty) (sv : V.symbolic_value) + (nsv : V.symbolic_value) (ctx : C.eval_ctx) : C.eval_ctx = + (* Sanity checks *) + assert (sv.sv_id <> nsv.sv_id); + (match nsv.sv_kind with + | V.SynthInputGivenBack | V.SynthRetGivenBack | V.FunCallGivenBack -> () + | V.FunCallRet | V.SynthInput | V.Global -> failwith "Unrechable"); + (* Store the given-back value as a meta-value for synthesis purposes *) + let mv = nsv in + (* Substitution function, to replace the borrow projectors over symbolic values *) + let subst (_abs : V.abs) local_given_back = + (* See the below comments: there is something wrong here *) + let _ = raise Errors.Unimplemented in + (* Compute the projection over the given back value *) + let child_proj = + match nsv.sv_kind with + | V.SynthRetGivenBack -> + (* The given back value comes from the return value of the function + we are currently synthesizing (as it is given back, it means + we ended one of the regions appearing in the signature: we are + currently synthesizing one of the backward functions). + + As we don't allow borrow overwrites on returned value, we can + (and MUST) forget the borrows *) + V.AIgnoredProjBorrows + | V.FunCallGivenBack -> + (* TODO: there is something wrong here. + Consider this: + {[ + abs0 {'a} { AProjLoans (s0 : &'a mut T) [] } + abs1 {'b} { AProjBorrows (s0 : &'a mut T <: &'b mut T) } + ]} + + Upon ending abs1, we give back some fresh symbolic value [s1], + that we reinsert where the loan for [s0] is. However, the mutable + borrow in the type [&'a mut T] was ended: we give back a value of + type [T]! We thus *mustn't* introduce a projector here. + *) + V.AProjBorrows (nsv, sv.V.sv_ty) + | _ -> failwith "Unreachable" + in + V.AProjLoans (sv, (mv, child_proj) :: local_given_back) + in + update_intersecting_aproj_loans proj_regions proj_ty sv subst ctx + +(** Auxiliary function to end borrows. See [give_back]. + + This function is similar to {!give_back_value} but gives back an {!V.avalue} + (coming from an abstraction). + + It is used when ending a borrow inside an abstraction, when the corresponding + loan is inside the same abstraction (in which case we don't need to end the whole + abstraction). + + REMARK: this function can't be used to give back the values borrowed by + end abstraction when ending this abstraction. When doing this, we need + to convert the {!V.avalue} to a {!type:V.value} by introducing the proper symbolic values. + *) +let give_back_avalue_to_same_abstraction (_config : C.config) + (bid : V.BorrowId.id) (mv : V.mvalue) (nv : V.typed_avalue) + (ctx : C.eval_ctx) : C.eval_ctx = + (* We use a reference to check that we updated exactly one loan *) + let replaced : bool ref = ref false in + let set_replaced () = + assert (not !replaced); + replaced := true + in + let obj = + object (self) + inherit [_] C.map_eval_ctx as super + + (** This is a bit annoying, but as we need the type of the avalue we + are exploring, in order to be able to project the value we give + back, we need to reimplement {!visit_typed_avalue} instead of + {!visit_ALoan} *) + method! visit_typed_avalue opt_abs (av : V.typed_avalue) : V.typed_avalue + = + match av.V.value with + | V.ALoan lc -> + let value = self#visit_typed_ALoan opt_abs av.V.ty lc in + ({ av with V.value } : V.typed_avalue) + | _ -> super#visit_typed_avalue opt_abs av + + (** We are not specializing an already existing method, but adding a + new method (for projections, we need type information) *) + method visit_typed_ALoan (opt_abs : V.abs option) (ty : T.rty) + (lc : V.aloan_content) : V.avalue = + match lc with + | V.AMutLoan (bid', child) -> + if bid' = bid then ( + (* Sanity check - about why we need to call {!ty_get_ref} + * (and don't do the same thing as in {!give_back_value}) + * see the comment at the level of the definition of + * {!typed_avalue} *) + let _, expected_ty, _ = ty_get_ref ty in + if nv.V.ty <> expected_ty then ( + log#serror + ("give_back_avalue_to_same_abstraction: improper type:\n\ + - expected: " ^ rty_to_string ctx ty ^ "\n- received: " + ^ rty_to_string ctx nv.V.ty); + failwith "Value given back doesn't have the proper type"); + (* This is the loan we are looking for: apply the projection to + * the value we give back and replaced this mutable loan with + * an ended loan *) + (* Register the insertion *) + set_replaced (); + (* Return the new value *) + V.ALoan + (V.AEndedMutLoan + { given_back = nv; child; given_back_meta = mv })) + else (* Continue exploring *) + super#visit_ALoan opt_abs lc + | V.ASharedLoan (_, _, _) + (* We are giving back a value to a *mutable* loan: nothing special to do *) + | V.AEndedMutLoan { given_back = _; child = _; given_back_meta = _ } + | V.AEndedSharedLoan (_, _) -> + (* Nothing special to do *) + super#visit_ALoan opt_abs lc + | V.AIgnoredMutLoan (bid', child) -> + (* This loan is ignored, but we may have to project on a subvalue + * of the value which is given back *) + if bid' = bid then ( + (* Note that we replace the ignored mut loan by an *ended* ignored + * mut loan. Also, this is not the loan we are looking for *per se*: + * we don't register the fact that we inserted the value somewhere + * (i.e., we don't call {!set_replaced}) *) + (* Sanity check *) + assert (nv.V.ty = ty); + V.ALoan + (V.AEndedIgnoredMutLoan + { given_back = nv; child; given_back_meta = mv })) + else super#visit_ALoan opt_abs lc + | V.AEndedIgnoredMutLoan + { given_back = _; child = _; given_back_meta = _ } + | V.AIgnoredSharedLoan _ -> + (* Nothing special to do *) + super#visit_ALoan opt_abs lc + end + in + + (* Explore the environment *) + let ctx = obj#visit_eval_ctx None ctx in + (* Check we gave back to exactly one loan *) + assert !replaced; + (* Return *) + ctx + +(** Auxiliary function to end borrows. See [give_back]. + + When we end a shared borrow, we need to remove the borrow id from the list + of borrows to the shared value. + + Note that this function checks that there is exactly one shared loan that + we update. + TODO: this was not the case before, so some sanity checks are not useful anymore. + *) +let give_back_shared _config (bid : V.BorrowId.id) (ctx : C.eval_ctx) : + C.eval_ctx = + (* We use a reference to check that we updated exactly one loan *) + let replaced : bool ref = ref false in + let set_replaced () = + assert (not !replaced); + replaced := true + in + let obj = + object + inherit [_] C.map_eval_ctx as super + + method! visit_Loan opt_abs lc = + match lc with + | V.SharedLoan (bids, shared_value) -> + if V.BorrowId.Set.mem bid bids then ( + (* This is the loan we are looking for *) + set_replaced (); + (* If there remains exactly one borrow identifier, we need + * to end the loan. Otherwise, we just remove the current + * loan identifier *) + if V.BorrowId.Set.cardinal bids = 1 then shared_value.V.value + else + V.Loan + (V.SharedLoan (V.BorrowId.Set.remove bid bids, shared_value))) + else + (* Not the loan we are looking for: continue exploring *) + V.Loan (super#visit_SharedLoan opt_abs bids shared_value) + | V.MutLoan bid' -> + (* We are giving back a *shared* borrow: nothing special to do *) + V.Loan (super#visit_MutLoan opt_abs bid') + + method! visit_ALoan opt_abs lc = + match lc with + | V.AMutLoan (bid, av) -> + (* Nothing special to do (we are giving back a *shared* borrow) *) + V.ALoan (super#visit_AMutLoan opt_abs bid av) + | V.ASharedLoan (bids, shared_value, child) -> + if V.BorrowId.Set.mem bid bids then ( + (* This is the loan we are looking for *) + set_replaced (); + (* If there remains exactly one borrow identifier, we need + * to end the loan. Otherwise, we just remove the current + * loan identifier *) + if V.BorrowId.Set.cardinal bids = 1 then + V.ALoan (V.AEndedSharedLoan (shared_value, child)) + else + V.ALoan + (V.ASharedLoan + (V.BorrowId.Set.remove bid bids, shared_value, child))) + else + (* Not the loan we are looking for: continue exploring *) + super#visit_ALoan opt_abs lc + | V.AEndedMutLoan { given_back = _; child = _; given_back_meta = _ } + (* Nothing special to do (the loan has ended) *) + | V.AEndedSharedLoan (_, _) + (* Nothing special to do (the loan has ended) *) + | V.AIgnoredMutLoan (_, _) + (* Nothing special to do (we are giving back a *shared* borrow) *) + | V.AEndedIgnoredMutLoan + { given_back = _; child = _; given_back_meta = _ } + (* Nothing special to do *) + | V.AIgnoredSharedLoan _ -> + (* Nothing special to do *) + super#visit_ALoan opt_abs lc + end + in + + (* Explore the environment *) + let ctx = obj#visit_eval_ctx None ctx in + (* Check we gave back to exactly one loan *) + assert !replaced; + (* Return *) + ctx + +(** When copying values, we duplicate the shared borrows. This is tantamount + to reborrowing the shared value. The following function applies this change + to an environment by inserting a new borrow id in the set of borrows tracked + by a shared value, referenced by the [original_bid] argument. + *) +let reborrow_shared (original_bid : V.BorrowId.id) (new_bid : V.BorrowId.id) + (ctx : C.eval_ctx) : C.eval_ctx = + (* Keep track of changes *) + let r = ref false in + let set_ref () = + assert (not !r); + r := true + in + + let obj = + object + inherit [_] C.map_env as super + + method! visit_SharedLoan env bids sv = + (* Shared loan: check if the borrow id we are looking for is in the + set of borrow ids. If yes, insert the new borrow id, otherwise + explore inside the shared value *) + if V.BorrowId.Set.mem original_bid bids then ( + set_ref (); + let bids' = V.BorrowId.Set.add new_bid bids in + V.SharedLoan (bids', sv)) + else super#visit_SharedLoan env bids sv + + method! visit_ASharedLoan env bids v av = + (* This case is similar to the {!SharedLoan} case *) + if V.BorrowId.Set.mem original_bid bids then ( + set_ref (); + let bids' = V.BorrowId.Set.add new_bid bids in + V.ASharedLoan (bids', v, av)) + else super#visit_ASharedLoan env bids v av + end + in + + let env = obj#visit_env () ctx.env in + (* Check that we reborrowed once *) + assert !r; + { ctx with env } + +(** Auxiliary function: see [end_borrow] *) +let give_back (config : C.config) (l : V.BorrowId.id) (bc : g_borrow_content) + (ctx : C.eval_ctx) : C.eval_ctx = + (* Debug *) + log#ldebug + (lazy + (let bc = + match bc with + | Concrete bc -> borrow_content_to_string ctx bc + | Abstract bc -> aborrow_content_to_string ctx bc + in + "give_back:\n- bid: " ^ V.BorrowId.to_string l ^ "\n- content: " ^ bc + ^ "\n- context:\n" ^ eval_ctx_to_string ctx ^ "\n")); + (* This is used for sanity checks *) + let sanity_ek = + { enter_shared_loans = true; enter_mut_borrows = true; enter_abs = true } + in + match bc with + | Concrete (V.MutBorrow (l', tv)) -> + (* Sanity check *) + assert (l' = l); + assert (not (loans_in_value tv)); + (* Check that the corresponding loan is somewhere - purely a sanity check *) + assert (Option.is_some (lookup_loan_opt sanity_ek l ctx)); + (* Update the context *) + give_back_value config l tv ctx + | Concrete (V.SharedBorrow (_, l') | V.InactivatedMutBorrow (_, l')) -> + (* Sanity check *) + assert (l' = l); + (* Check that the borrow is somewhere - purely a sanity check *) + assert (Option.is_some (lookup_loan_opt sanity_ek l ctx)); + (* Update the context *) + give_back_shared config l ctx + | Abstract (V.AMutBorrow (mv, l', av)) -> + (* Sanity check *) + assert (l' = l); + (* Check that the corresponding loan is somewhere - purely a sanity check *) + assert (Option.is_some (lookup_loan_opt sanity_ek l ctx)); + (* Update the context *) + give_back_avalue_to_same_abstraction config l mv av ctx + | Abstract (V.ASharedBorrow l') -> + (* Sanity check *) + assert (l' = l); + (* Check that the borrow is somewhere - purely a sanity check *) + assert (Option.is_some (lookup_loan_opt sanity_ek l ctx)); + (* Update the context *) + give_back_shared config l ctx + | Abstract (V.AProjSharedBorrow asb) -> + (* Sanity check *) + assert (borrow_in_asb l asb); + (* Update the context *) + give_back_shared config l ctx + | Abstract + ( V.AEndedMutBorrow _ | V.AIgnoredMutBorrow _ | V.AEndedIgnoredMutBorrow _ + | V.AEndedSharedBorrow ) -> + failwith "Unreachable" + +(** Convert an {!type:V.avalue} to a {!type:V.value}. + + This function is used when ending abstractions: whenever we end a borrow + in an abstraction, we converted the borrowed {!V.avalue} to a fresh symbolic + {!type:V.value}, then give back this {!type:V.value} to the context. + + Note that some regions may have ended in the symbolic value we generate. + For instance, consider the following function signature: + {[ + fn f<'a>(x : &'a mut &'a mut u32); + ]} + When ending the abstraction, the value given back for the outer borrow + should be ⊥. In practice, we will give back a symbolic value which can't + be expanded (because expanding this symbolic value would require expanding + a reference whose region has already ended). + *) +let convert_avalue_to_given_back_value (abs_kind : V.abs_kind) + (av : V.typed_avalue) : V.symbolic_value = + let sv_kind = + match abs_kind with + | V.FunCall -> V.FunCallGivenBack + | V.SynthRet -> V.SynthRetGivenBack + | V.SynthInput -> V.SynthInputGivenBack + in + mk_fresh_symbolic_value sv_kind av.V.ty + +(** End a borrow identified by its borrow id in a context. + + Rk.: from now onwards, the functions are written in continuation passing style. + The reason is that when ending borrows we may end abstractions, which results + in synthesized code. + + First lookup the borrow in the context and replace it with {!V.Bottom}. + Then, check that there is an associated loan in the context. When moving + values, before putting the value in its destination, we get an + intermediate state where some values are "outside" the context and thus + inaccessible. As {!give_back_value} just performs a map for instance (TODO: + not the case anymore), we need to check independently that there is indeed a + loan ready to receive the value we give back (note that we also have other + invariants like: there is exacly one mutable loan associated to a mutable + borrow, etc. but they are more easily maintained). + Note that in theory, we shouldn't never reach a problematic state as the + one we describe above, because when we move a value we need to end all the + loans inside before moving it. Still, it is a very useful sanity check. + Finally, give the values back. + + Of course, we end outer borrows before updating the target borrow if it + proves necessary. + If a borrow is inside an abstraction, we need to end the whole abstraction, + at the exception of the case where the loan corresponding to the borrow is + inside the same abstraction. We control this with the [allowed_abs] parameter: + if it is not [None], we allow ending a borrow if it is inside the given + abstraction. In practice, if the value is [Some abs_id], we should have + checked that the corresponding loan is inside the abstraction given by + [abs_id] before. In practice, only {!end_borrow} should call itself + with [allowed_abs = Some ...], all the other calls should use [allowed_abs = None]: + if you look ath the implementation details, [end_borrow] performs + all tne necessary checks in case a borrow is inside an abstraction. + TODO: we shouldn't allow this last case (end a borrow when the corresponding + loan is in the same abstraction). + + TODO: we should split this function in two: one function which doesn't + perform anything smart and is trusted, and another function for the + book-keeping. + *) +let rec end_borrow (config : C.config) (chain : borrow_or_abs_ids) + (allowed_abs : V.AbstractionId.id option) (l : V.BorrowId.id) : cm_fun = + fun cf ctx -> + (* Check that we don't loop *) + let chain0 = chain in + let chain = add_borrow_or_abs_id_to_chain "end_borrow: " (BorrowId l) chain in + log#ldebug + (lazy + ("end borrow: " ^ V.BorrowId.to_string l ^ ":\n- original context:\n" + ^ eval_ctx_to_string ctx)); + + (* Utility function for the sanity checks: check that the borrow disappeared + * from the context *) + let ctx0 = ctx in + let check_disappeared (ctx : C.eval_ctx) : unit = + let _ = + match lookup_borrow_opt ek_all l ctx with + | None -> () (* Ok *) + | Some _ -> + log#lerror + (lazy + ("end borrow: " ^ V.BorrowId.to_string l + ^ ": borrow didn't disappear:\n- original context:\n" + ^ eval_ctx_to_string ctx0 ^ "\n\n- new context:\n" + ^ eval_ctx_to_string ctx)); + failwith "Borrow not eliminated" + in + match lookup_loan_opt ek_all l ctx with + | None -> () (* Ok *) + | Some _ -> + log#lerror + (lazy + ("end borrow: " ^ V.BorrowId.to_string l + ^ ": loan didn't disappear:\n- original context:\n" + ^ eval_ctx_to_string ctx0 ^ "\n\n- new context:\n" + ^ eval_ctx_to_string ctx)); + failwith "Loan not eliminated" + in + let cf_check_disappeared : cm_fun = unit_to_cm_fun check_disappeared in + (* The complete sanity check: also check that after we ended a borrow, + * the invariant is preserved *) + let cf_check : cm_fun = + comp cf_check_disappeared (Invariants.cf_check_invariants config) + in + + (* Start by getting the borrow *) + match end_borrow_get_borrow allowed_abs l ctx with + (* Two cases: + * - error: we found outer borrows or inner loans (end them first) + * - success: we didn't find outer borrows when updating (but maybe we actually + didn't find the borrow we were looking for...) + *) + | Error priority -> ( + (* Debug *) + log#ldebug + (lazy + ("end borrow: " ^ V.BorrowId.to_string l + ^ ": found outer borrows/abs or inner loans:" + ^ show_priority_borrows_or_abs priority)); + (* End the priority borrows, abstraction, then try again to end the target + * borrow (if necessary) *) + match priority with + | OuterBorrows (Borrows bids) | InnerLoans (Borrows bids) -> + (* Note that we might get there with [allowed_abs <> None]: we might + * be trying to end a borrow inside an abstraction, but which is actually + * inside another borrow *) + let allowed_abs' = None in + (* End the outer borrows *) + let cc = end_borrows config chain allowed_abs' bids in + (* Retry to end the borrow *) + let cc = comp cc (end_borrow config chain0 allowed_abs l) in + (* Check and apply *) + comp cc cf_check cf ctx + | OuterBorrows (Borrow bid) | InnerLoans (Borrow bid) -> + let allowed_abs' = None in + (* End the outer borrow *) + let cc = end_borrow config chain allowed_abs' bid in + (* Retry to end the borrow *) + let cc = comp cc (end_borrow config chain0 allowed_abs l) in + (* Check and apply *) + comp cc cf_check cf ctx + | OuterAbs abs_id -> + (* The borrow is inside an asbtraction: check if the corresponding + * loan is inside the same abstraction. If this is the case, we end + * the borrow without ending the abstraction. If not, we need to + * end the whole abstraction *) + (* Note that we can lookup the loan anywhere *) + let ek = + { + enter_shared_loans = true; + enter_mut_borrows = true; + enter_abs = true; + } + in + let cf_end_abs : cm_fun = + match lookup_loan ek l ctx with + | AbsId loan_abs_id, _ -> + if loan_abs_id = abs_id then + (* Same abstraction! We can end the borrow *) + end_borrow config chain0 (Some abs_id) l + else + (* Not the same abstraction: we need to end the whole abstraction. + * By doing that we should have ended the target borrow (see the + * below sanity check) *) + end_abstraction config chain abs_id + | VarId _, _ -> + (* The loan is not inside the same abstraction (actually inside + * a non-abstraction value): we need to end the whole abstraction *) + end_abstraction config chain abs_id + in + (* Compose with a sanity check *) + comp cf_end_abs cf_check cf ctx) + | Ok (ctx, None) -> + log#ldebug (lazy "End borrow: borrow not found"); + (* It is possible that we can't find a borrow in symbolic mode (ending + * an abstraction may end several borrows at once *) + assert (config.mode = SymbolicMode); + (* Do a sanity check and continue *) + cf_check cf ctx + (* We found a borrow: give it back (i.e., update the corresponding loan) *) + | Ok (ctx, Some bc) -> + (* Sanity check: the borrowed value shouldn't contain loans *) + (match bc with + | Concrete (V.MutBorrow (_, bv)) -> + assert (Option.is_none (get_first_loan_in_value bv)) + | _ -> ()); + (* Give back the value *) + let ctx = give_back config l bc ctx in + (* Do a sanity check and continue *) + cf_check cf ctx + +and end_borrows (config : C.config) (chain : borrow_or_abs_ids) + (allowed_abs : V.AbstractionId.id option) (lset : V.BorrowId.Set.t) : cm_fun + = + fun cf -> + (* This is not necessary, but we prefer to reorder the borrow ids, + * so that we actually end from the smallest id to the highest id - just + * a matter of taste, and may make debugging easier *) + let ids = V.BorrowId.Set.fold (fun id ids -> id :: ids) lset [] in + List.fold_left (fun cf id -> end_borrow config chain allowed_abs id cf) cf ids + +and end_abstraction (config : C.config) (chain : borrow_or_abs_ids) + (abs_id : V.AbstractionId.id) : cm_fun = + fun cf ctx -> + (* Check that we don't loop *) + let chain = + add_borrow_or_abs_id_to_chain "end_abstraction: " (AbsId abs_id) chain + in + (* Remember the original context for printing purposes *) + let ctx0 = ctx in + log#ldebug + (lazy + ("end_abstraction: " + ^ V.AbstractionId.to_string abs_id + ^ "\n- original context:\n" ^ eval_ctx_to_string ctx0)); + + (* Lookup the abstraction *) + let abs = C.ctx_lookup_abs ctx abs_id in + + (* Check that we can end the abstraction *) + assert abs.can_end; + + (* End the parent abstractions first *) + let cc = end_abstractions config chain abs.parents in + let cc = + comp_unit cc (fun ctx -> + log#ldebug + (lazy + ("end_abstraction: " + ^ V.AbstractionId.to_string abs_id + ^ "\n- context after parent abstractions ended:\n" + ^ eval_ctx_to_string ctx))) + in + + (* End the loans inside the abstraction *) + let cc = comp cc (end_abstraction_loans config chain abs_id) in + let cc = + comp_unit cc (fun ctx -> + log#ldebug + (lazy + ("end_abstraction: " + ^ V.AbstractionId.to_string abs_id + ^ "\n- context after loans ended:\n" ^ eval_ctx_to_string ctx))) + in + + (* End the abstraction itself by redistributing the borrows it contains *) + let cc = comp cc (end_abstraction_borrows config chain abs_id) in + + (* End the regions owned by the abstraction - note that we don't need to + * relookup the abstraction: the set of regions in an abstraction never + * changes... *) + let cc = + comp_update cc (fun ctx -> + let ended_regions = + T.RegionId.Set.union ctx.ended_regions abs.V.regions + in + { ctx with ended_regions }) + in + + (* Remove all the references to the id of the current abstraction, and remove + * the abstraction itself. + * **Rk.**: this is where we synthesize the updated symbolic AST *) + let cc = comp cc (end_abstraction_remove_from_context config abs_id) in + + (* Debugging *) + let cc = + comp_unit cc (fun ctx -> + log#ldebug + (lazy + ("end_abstraction: " + ^ V.AbstractionId.to_string abs_id + ^ "\n- original context:\n" ^ eval_ctx_to_string ctx0 + ^ "\n\n- new context:\n" ^ eval_ctx_to_string ctx))) + in + + (* Sanity check: ending an abstraction must preserve the invariants *) + let cc = comp cc (Invariants.cf_check_invariants config) in + + (* Apply the continuation *) + cc cf ctx + +and end_abstractions (config : C.config) (chain : borrow_or_abs_ids) + (abs_ids : V.AbstractionId.Set.t) : cm_fun = + fun cf -> + (* This is not necessary, but we prefer to reorder the abstraction ids, + * so that we actually end from the smallest id to the highest id - just + * a matter of taste, and may make debugging easier *) + let abs_ids = V.AbstractionId.Set.fold (fun id ids -> id :: ids) abs_ids [] in + List.fold_left (fun cf id -> end_abstraction config chain id cf) cf abs_ids + +and end_abstraction_loans (config : C.config) (chain : borrow_or_abs_ids) + (abs_id : V.AbstractionId.id) : cm_fun = + fun cf ctx -> + (* Lookup the abstraction *) + let abs = C.ctx_lookup_abs ctx abs_id in + (* End the first loan we find. + * + * We ignore the "ignored mut/shared loans": as we should have already ended + * the parent abstractions, they necessarily come from children. *) + let opt_loan = get_first_non_ignored_aloan_in_abstraction abs in + match opt_loan with + | None -> + (* No loans: nothing to update *) + cf ctx + | Some (BorrowIds bids) -> + (* There are loans: end the corresponding borrows, then recheck *) + let cc : cm_fun = + match bids with + | Borrow bid -> end_borrow config chain None bid + | Borrows bids -> end_borrows config chain None bids + in + (* Reexplore, looking for loans *) + let cc = comp cc (end_abstraction_loans config chain abs_id) in + (* Continue *) + cc cf ctx + | Some (SymbolicValue sv) -> + (* There is a proj_loans over a symbolic value: end the proj_borrows + * which intersect this proj_loans, then end the proj_loans itself *) + let cc = end_proj_loans_symbolic config chain abs_id abs.regions sv in + (* Reexplore, looking for loans *) + let cc = comp cc (end_abstraction_loans config chain abs_id) in + (* Continue *) + cc cf ctx + +and end_abstraction_borrows (config : C.config) (chain : borrow_or_abs_ids) + (abs_id : V.AbstractionId.id) : cm_fun = + fun cf ctx -> + log#ldebug + (lazy + ("end_abstraction_borrows: abs_id: " ^ V.AbstractionId.to_string abs_id)); + (* Note that the abstraction mustn't contain any loans *) + (* We end the borrows, starting with the *inner* ones. This is important + when considering nested borrows which have the same lifetime. + TODO: is that really important? Initially, there was a concern about + whether we should give back ⊥ or not, but everything is handled by + the symbolic value expansion... Also, now we use the AEndedMutBorrow + values to store the children avalues (which was not the case before - we + initially replaced the ended mut borrows with ⊥). + *) + (* We explore in-depth and use exceptions. When exploring a borrow, if + * the exploration didn't trigger an exception, it means there are no + * inner borrows to end: we can thus trigger an exception for the current + * borrow. *) + let obj = + object + inherit [_] V.iter_abs as super + + method! visit_aborrow_content env bc = + (* In-depth exploration *) + super#visit_aborrow_content env bc; + (* No exception was raise: we can raise an exception for the + * current borrow *) + match bc with + | V.AMutBorrow (_, _, _) | V.ASharedBorrow _ -> + (* Raise an exception *) + raise (FoundABorrowContent bc) + | V.AProjSharedBorrow asb -> + (* Raise an exception only if the asb contains borrows *) + if + List.exists + (fun x -> match x with V.AsbBorrow _ -> true | _ -> false) + asb + then raise (FoundABorrowContent bc) + else () + | V.AEndedMutBorrow _ | V.AIgnoredMutBorrow _ + | V.AEndedIgnoredMutBorrow _ | V.AEndedSharedBorrow -> + (* Nothing to do for ignored borrows *) + () + + method! visit_aproj env sproj = + (match sproj with + | V.AProjLoans _ -> failwith "Unexpected" + | V.AProjBorrows (sv, proj_ty) -> + raise (FoundAProjBorrows (sv, proj_ty)) + | V.AEndedProjLoans _ | V.AEndedProjBorrows _ | V.AIgnoredProjBorrows -> + ()); + super#visit_aproj env sproj + + (** We may need to end borrows in "regular" values, because of shared values *) + method! visit_borrow_content _ bc = + match bc with + | V.SharedBorrow (_, _) | V.MutBorrow (_, _) -> + raise (FoundBorrowContent bc) + | V.InactivatedMutBorrow _ -> failwith "Unreachable" + end + in + (* Lookup the abstraction *) + let abs = C.ctx_lookup_abs ctx abs_id in + try + (* Explore the abstraction, looking for borrows *) + obj#visit_abs () abs; + (* No borrows: nothing to update *) + cf ctx + with + (* There are concrete (i.e., not symbolic) borrows: end them, then reexplore *) + | FoundABorrowContent bc -> + log#ldebug + (lazy + ("end_abstraction_borrows: found aborrow content: " + ^ aborrow_content_to_string ctx bc)); + let ctx = + match bc with + | V.AMutBorrow (_mv, bid, av) -> + (* First, convert the avalue to a (fresh symbolic) value *) + let sv = convert_avalue_to_given_back_value abs.kind av in + (* Replace the mut borrow to register the fact that we ended + * it and store with it the freshly generated given back value *) + let ended_borrow = V.ABorrow (V.AEndedMutBorrow (sv, av)) in + let ctx = update_aborrow ek_all bid ended_borrow ctx in + (* Give the value back *) + let sv = mk_typed_value_from_symbolic_value sv in + give_back_value config bid sv ctx + | V.ASharedBorrow bid -> + (* Replace the shared borrow to account for the fact it ended *) + let ended_borrow = V.ABorrow V.AEndedSharedBorrow in + let ctx = update_aborrow ek_all bid ended_borrow ctx in + (* Give back *) + give_back_shared config bid ctx + | V.AProjSharedBorrow asb -> + (* Retrieve the borrow ids *) + let bids = + List.filter_map + (fun asb -> + match asb with + | V.AsbBorrow bid -> Some bid + | V.AsbProjReborrows (_, _) -> None) + asb + in + (* There should be at least one borrow identifier in the set, which we + * can use to identify the whole set *) + let repr_bid = List.hd bids in + (* Replace the shared borrow with Bottom *) + let ctx = update_aborrow ek_all repr_bid V.ABottom ctx in + (* Give back the shared borrows *) + let ctx = + List.fold_left + (fun ctx bid -> give_back_shared config bid ctx) + ctx bids + in + (* Continue *) + ctx + | V.AEndedMutBorrow _ | V.AIgnoredMutBorrow _ + | V.AEndedIgnoredMutBorrow _ | V.AEndedSharedBorrow -> + failwith "Unexpected" + in + (* Reexplore *) + end_abstraction_borrows config chain abs_id cf ctx + (* There are symbolic borrows: end them, then reexplore *) + | FoundAProjBorrows (sv, proj_ty) -> + log#ldebug + (lazy + ("end_abstraction_borrows: found aproj borrows: " + ^ aproj_to_string ctx (V.AProjBorrows (sv, proj_ty)))); + (* Generate a fresh symbolic value *) + let nsv = mk_fresh_symbolic_value V.FunCallGivenBack proj_ty in + (* Replace the proj_borrows - there should be exactly one *) + let ended_borrow = V.AEndedProjBorrows nsv in + let ctx = update_aproj_borrows abs.abs_id sv ended_borrow ctx in + (* Give back the symbolic value *) + let ctx = + give_back_symbolic_value config abs.regions proj_ty sv nsv ctx + in + (* Reexplore *) + end_abstraction_borrows config chain abs_id cf ctx + (* There are concrete (i.e., not symbolic) borrows in shared values: end them, then reexplore *) + | FoundBorrowContent bc -> + log#ldebug + (lazy + ("end_abstraction_borrows: found borrow content: " + ^ borrow_content_to_string ctx bc)); + let ctx = + match bc with + | V.SharedBorrow (_, bid) -> ( + (* Replace the shared borrow with bottom *) + match end_borrow_get_borrow (Some abs_id) bid ctx with + | Error _ -> failwith "Unreachable" + | Ok (ctx, _) -> + (* Give back *) + give_back_shared config bid ctx) + | V.MutBorrow (bid, v) -> ( + (* Replace the mut borrow with bottom *) + match end_borrow_get_borrow (Some abs_id) bid ctx with + | Error _ -> failwith "Unreachable" + | Ok (ctx, _) -> + (* Give the value back - note that the mut borrow was below a + * shared borrow: the value is thus unchanged *) + give_back_value config bid v ctx) + | V.InactivatedMutBorrow _ -> failwith "Unreachable" + in + (* Reexplore *) + end_abstraction_borrows config chain abs_id cf ctx + +(** Remove an abstraction from the context, as well as all its references *) +and end_abstraction_remove_from_context (_config : C.config) + (abs_id : V.AbstractionId.id) : cm_fun = + fun cf ctx -> + let rec remove_from_env (env : C.env) : C.env * V.abs option = + match env with + | [] -> failwith "Unreachable" + | C.Frame :: _ -> (env, None) + | Var (bv, v) :: env -> + let env, abs_opt = remove_from_env env in + (Var (bv, v) :: env, abs_opt) + | C.Abs abs :: env -> + if abs.abs_id = abs_id then (env, Some abs) + else + let env, abs_opt = remove_from_env env in + let parents = V.AbstractionId.Set.remove abs_id abs.parents in + (C.Abs { abs with V.parents } :: env, abs_opt) + in + let env, abs = remove_from_env ctx.C.env in + let ctx = { ctx with C.env } in + let abs = Option.get abs in + (* Apply the continuation *) + let expr = cf ctx in + (* Synthesize the symbolic AST *) + S.synthesize_end_abstraction abs expr + +(** End a proj_loan over a symbolic value by ending the proj_borrows which + intersect this proj_loans. + + Rk.: + - if this symbolic value is primitively copiable, then: + - either proj_borrows are only present in the concrete context + - or there is only one intersecting proj_borrow present in an + abstraction + - otherwise, this symbolic value is not primitively copiable: + - there may be proj_borrows_shared over this value + - if we put aside the proj_borrows_shared, there should be exactly one + intersecting proj_borrows, either in the concrete context or in an + abstraction +*) +and end_proj_loans_symbolic (config : C.config) (chain : borrow_or_abs_ids) + (abs_id : V.AbstractionId.id) (regions : T.RegionId.Set.t) + (sv : V.symbolic_value) : cm_fun = + fun cf ctx -> + (* Small helpers for sanity checks *) + let check ctx = no_aproj_over_symbolic_in_context sv ctx in + let cf_check (cf : m_fun) : m_fun = + fun ctx -> + check ctx; + cf ctx + in + (* Find the first proj_borrows which intersects the proj_loans *) + let explore_shared = true in + match lookup_intersecting_aproj_borrows_opt explore_shared regions sv ctx with + | None -> + (* We couldn't find any in the context: it means that the symbolic value + * is in the concrete environment (or that we dropped it, in which case + * it is completely absent). We thus simply need to replace the loans + * projector with an ended projector. *) + let ctx = update_aproj_loans_to_ended abs_id sv ctx in + (* Sanity check *) + check ctx; + (* Continue *) + cf ctx + | Some (SharedProjs projs) -> + (* We found projectors over shared values - split between the projectors + which belong to the current abstraction and the others. + The context looks like this: + {[ + abs'0 { + // The loan was initially like this: + // [shared_loan lids (s <: ...) [s]] + // but if we get there it means it was already ended: + ended_shared_loan (s <: ...) [s] + proj_shared_borrows [...; (s <: ...); ...] + proj_shared_borrows [...; (s <: ...); ...] + ... + } + + abs'1 [ + proj_shared_borrows [...; (s <: ...); ...] + ... + } + + ... + + // No [s] outside of abstractions + + ]} + *) + let _owned_projs, external_projs = + List.partition (fun (abs_id', _) -> abs_id' = abs_id) projs + in + (* End the external borrow projectors (end their abstractions) *) + let cf_end_external : cm_fun = + fun cf ctx -> + let abs_ids = List.map fst external_projs in + let abs_ids = + List.fold_left + (fun s id -> V.AbstractionId.Set.add id s) + V.AbstractionId.Set.empty abs_ids + in + (* End the abstractions and continue *) + end_abstractions config chain abs_ids cf ctx + in + (* End the internal borrows projectors and the loans projector *) + let cf_end_internal : cm_fun = + fun cf ctx -> + (* All the proj_borrows are owned: simply erase them *) + let ctx = remove_intersecting_aproj_borrows_shared regions sv ctx in + (* End the loan itself *) + let ctx = update_aproj_loans_to_ended abs_id sv ctx in + (* Sanity check *) + check ctx; + (* Continue *) + cf ctx + in + (* Compose and apply *) + let cc = comp cf_end_external cf_end_internal in + cc cf ctx + | Some (NonSharedProj (abs_id', _proj_ty)) -> + (* We found one projector of borrows in an abstraction: if it comes + * from this abstraction, we can end it directly, otherwise we need + * to end the abstraction where it came from first *) + if abs_id' = abs_id then ( + (* Note that it happens when a function returns a [&mut ...] which gets + expanded to [mut_borrow l s], and we end the borrow [l] (so [s] gets + reinjected in the parent abstraction without having been modified). + + The context looks like this: + {[ + abs'0 { + [s <: ...] + (s <: ...) + } + + // Note that [s] can't appear in other abstractions or in the + // regular environment (because we forbid the duplication of + // symbolic values which contain borrows). + ]} + *) + (* End the projector of borrows - TODO: not completely sure what to + * replace it with... Maybe we should introduce an ABottomProj? *) + let ctx = update_aproj_borrows abs_id sv V.AIgnoredProjBorrows ctx in + (* Sanity check: no other occurrence of an intersecting projector of borrows *) + assert ( + Option.is_none + (lookup_intersecting_aproj_borrows_opt explore_shared regions sv ctx)); + (* End the projector of loans *) + let ctx = update_aproj_loans_to_ended abs_id sv ctx in + (* Sanity check *) + check ctx; + (* Continue *) + cf ctx) + else + (* The borrows proj comes from a different abstraction: end it. *) + let cc = end_abstraction config chain abs_id' in + (* Retry ending the projector of loans *) + let cc = + comp cc (end_proj_loans_symbolic config chain abs_id regions sv) + in + (* Sanity check *) + let cc = comp cc cf_check in + (* Continue *) + cc cf ctx + +let end_outer_borrow config : V.BorrowId.id -> cm_fun = + end_borrow config [] None + +let end_outer_borrows config : V.BorrowId.Set.t -> cm_fun = + end_borrows config [] None + +(** Helper function: see [activate_inactivated_mut_borrow]. + + This function updates the shared loan to a mutable loan (we then update + the borrow with another helper). Of course, the shared loan must contain + exactly one borrow id (the one we give as parameter), otherwise we can't + promote it. Also, the shared value mustn't contain any loan. + + The returned value (previously shared) is checked: + - it mustn't contain loans + - it mustn't contain {!V.Bottom} + - it mustn't contain inactivated borrows + TODO: this kind of checks should be put in an auxiliary helper, because + they are redundant. + + The loan to update mustn't be a borrowed value. + *) +let promote_shared_loan_to_mut_loan (l : V.BorrowId.id) + (cf : V.typed_value -> m_fun) : m_fun = + fun ctx -> + (* Debug *) + log#ldebug + (lazy + ("promote_shared_loan_to_mut_loan:\n- loan: " ^ V.BorrowId.to_string l + ^ "\n- context:\n" ^ eval_ctx_to_string ctx ^ "\n")); + (* Lookup the shared loan - note that we can't promote a shared loan + * in a shared value, but we can do it in a mutably borrowed value. + * This is important because we can do: [let y = &two-phase ( *x );] + *) + let ek = + { enter_shared_loans = false; enter_mut_borrows = true; enter_abs = false } + in + match lookup_loan ek l ctx with + | _, Concrete (V.MutLoan _) -> + failwith "Expected a shared loan, found a mut loan" + | _, Concrete (V.SharedLoan (bids, sv)) -> + (* Check that there is only one borrow id (l) and update the loan *) + assert (V.BorrowId.Set.mem l bids && V.BorrowId.Set.cardinal bids = 1); + (* We need to check that there aren't any loans in the value: + we should have gotten rid of those already, but it is better + to do a sanity check. *) + assert (not (loans_in_value sv)); + (* Check there isn't {!Bottom} (this is actually an invariant *) + assert (not (bottom_in_value ctx.ended_regions sv)); + (* Check there aren't inactivated borrows *) + assert (not (inactivated_in_value sv)); + (* Update the loan content *) + let ctx = update_loan ek l (V.MutLoan l) ctx in + (* Continue *) + cf sv ctx + | _, Abstract _ -> + (* I don't think it is possible to have two-phase borrows involving borrows + * returned by abstractions. I'm not sure how we could handle that anyway. *) + failwith + "Can't promote a shared loan to a mutable loan if the loan is inside \ + an abstraction" + +(** Helper function: see {!activate_inactivated_mut_borrow}. + + This function updates a shared borrow to a mutable borrow. + *) +let promote_inactivated_borrow_to_mut_borrow (l : V.BorrowId.id) (cf : m_fun) + (borrowed_value : V.typed_value) : m_fun = + fun ctx -> + (* Lookup the inactivated borrow - note that we don't go inside borrows/loans: + there can't be inactivated borrows inside other borrows/loans + *) + let ek = + { enter_shared_loans = false; enter_mut_borrows = false; enter_abs = false } + in + let ctx = + match lookup_borrow ek l ctx with + | Concrete (V.SharedBorrow _ | V.MutBorrow (_, _)) -> + failwith "Expected an inactivated mutable borrow" + | Concrete (V.InactivatedMutBorrow _) -> + (* Update it *) + update_borrow ek l (V.MutBorrow (l, borrowed_value)) ctx + | Abstract _ -> + (* This can't happen for sure *) + failwith + "Can't promote a shared borrow to a mutable borrow if the borrow is \ + inside an abstraction" + in + (* Continue *) + cf ctx + +(** Promote an inactivated mut borrow to a mut borrow. + + The borrow must point to a shared value which is borrowed exactly once. + *) +let rec activate_inactivated_mut_borrow (config : C.config) (l : V.BorrowId.id) + : cm_fun = + fun cf ctx -> + (* Lookup the value *) + let ek = + { enter_shared_loans = false; enter_mut_borrows = true; enter_abs = false } + in + match lookup_loan ek l ctx with + | _, Concrete (V.MutLoan _) -> failwith "Unreachable" + | _, Concrete (V.SharedLoan (bids, sv)) -> ( + (* If there are loans inside the value, end them. Note that there can't be + inactivated borrows inside the value. + If we perform an update, do a recursive call to lookup the updated value *) + match get_first_loan_in_value sv with + | Some lc -> + (* End the loans *) + let cc = + match lc with + | V.SharedLoan (bids, _) -> end_outer_borrows config bids + | V.MutLoan bid -> end_outer_borrow config bid + in + (* Recursive call *) + let cc = comp cc (activate_inactivated_mut_borrow config l) in + (* Continue *) + cc cf ctx + | None -> + (* No loan to end inside the value *) + (* Some sanity checks *) + log#ldebug + (lazy + ("activate_inactivated_mut_borrow: resulting value:\n" + ^ typed_value_to_string ctx sv)); + assert (not (loans_in_value sv)); + assert (not (bottom_in_value ctx.ended_regions sv)); + assert (not (inactivated_in_value sv)); + (* End the borrows which borrow from the value, at the exception of + the borrow we want to promote *) + let bids = V.BorrowId.Set.remove l bids in + let cc = end_outer_borrows config bids in + (* Promote the loan - TODO: this will fail if the value contains + * any loans. In practice, it shouldn't, but we could also + * look for loans inside the value and end them before promoting + * the borrow. *) + let cc = comp cc (promote_shared_loan_to_mut_loan l) in + (* Promote the borrow - the value should have been checked by + {!promote_shared_loan_to_mut_loan} + *) + let cc = + comp cc (fun cf borrowed_value -> + promote_inactivated_borrow_to_mut_borrow l cf borrowed_value) + in + (* Continue *) + cc cf ctx) + | _, Abstract _ -> + (* I don't think it is possible to have two-phase borrows involving borrows + * returned by abstractions. I'm not sure how we could handle that anyway. *) + failwith + "Can't activate an inactivated mutable borrow referencing a loan inside\n\ + \ an abstraction" diff --git a/compiler/InterpreterBorrowsCore.ml b/compiler/InterpreterBorrowsCore.ml new file mode 100644 index 00000000..a5501712 --- /dev/null +++ b/compiler/InterpreterBorrowsCore.ml @@ -0,0 +1,1181 @@ +(* This file defines the basic blocks to implement the semantics of borrows. + * Note that those functions are not only used in InterpreterBorrows, but + * also in Invariants or InterpreterProjectors *) + +module T = Types +module V = Values +module C = Contexts +module Subst = Substitute +module L = Logging +open Utils +open TypesUtils +open InterpreterUtils + +(** The local logger *) +let log = L.borrows_log + +(** TODO: cleanup this a bit, once we have a better understanding about + what we need. + TODO: I'm not sure in which file this should be moved... *) +type exploration_kind = { + enter_shared_loans : bool; + enter_mut_borrows : bool; + enter_abs : bool; + (** Note that if we allow to enter abs, we don't check whether we enter + mutable/shared loans or borrows: there are no use cases requiring + a finer control. *) +} +(** This record controls how some generic helper lookup/update + functions behave, by restraining the kind of therms they can enter. +*) + +let ek_all : exploration_kind = + { enter_shared_loans = true; enter_mut_borrows = true; enter_abs = true } + +type borrow_ids = Borrows of V.BorrowId.Set.t | Borrow of V.BorrowId.id +[@@deriving show] + +exception FoundBorrowIds of borrow_ids + +type priority_borrows_or_abs = + | OuterBorrows of borrow_ids + | OuterAbs of V.AbstractionId.id + | InnerLoans of borrow_ids +[@@deriving show] + +type borrow_ids_or_symbolic_value = + | BorrowIds of borrow_ids + | SymbolicValue of V.symbolic_value +[@@deriving show] + +let update_if_none opt x = match opt with None -> Some x | _ -> opt + +(** Utility exception *) +exception FoundPriority of priority_borrows_or_abs + +type loan_or_borrow_content = + | LoanContent of V.loan_content + | BorrowContent of V.borrow_content +[@@deriving show] + +type borrow_or_abs_id = + | BorrowId of V.BorrowId.id + | AbsId of V.AbstractionId.id + +type borrow_or_abs_ids = borrow_or_abs_id list + +let borrow_or_abs_id_to_string (id : borrow_or_abs_id) : string = + match id with + | AbsId id -> "abs@" ^ V.AbstractionId.to_string id + | BorrowId id -> "l@" ^ V.BorrowId.to_string id + +let borrow_or_abs_ids_chain_to_string (ids : borrow_or_abs_ids) : string = + let ids = List.rev ids in + let ids = List.map borrow_or_abs_id_to_string ids in + String.concat " -> " ids + +(** Add a borrow or abs id to a chain of ids, while checking that we don't loop *) +let add_borrow_or_abs_id_to_chain (msg : string) (id : borrow_or_abs_id) + (ids : borrow_or_abs_ids) : borrow_or_abs_ids = + if List.mem id ids then + failwith + (msg ^ "detected a loop in the chain of ids: " + ^ borrow_or_abs_ids_chain_to_string (id :: ids)) + else id :: ids + +(** Helper function. + + This function allows to define in a generic way a comparison of region types. + See [projections_interesect] for instance. + + [default]: default boolean to return, when comparing types with no regions + [combine]: how to combine booleans + [compare_regions]: how to compare regions + *) +let rec compare_rtys (default : bool) (combine : bool -> bool -> bool) + (compare_regions : T.RegionId.id T.region -> T.RegionId.id T.region -> bool) + (ty1 : T.rty) (ty2 : T.rty) : bool = + let compare = compare_rtys default combine compare_regions in + match (ty1, ty2) with + | T.Bool, T.Bool | T.Char, T.Char | T.Str, T.Str -> default + | T.Integer int_ty1, T.Integer int_ty2 -> + assert (int_ty1 = int_ty2); + default + | T.Adt (id1, regions1, tys1), T.Adt (id2, regions2, tys2) -> + assert (id1 = id2); + + (* The check for the ADTs is very crude: we simply compare the arguments + * two by two. + * + * For instance, when checking if some projections intersect, we simply + * check if some arguments intersect. As all the type and region + * parameters should be used somewhere in the ADT (otherwise rustc + * generates an error), it means that it should be equivalent to checking + * whether two fields intersect (and anyway comparing the field types is + * difficult in case of enumerations...). + * If we didn't have the above property enforced by the rust compiler, + * this check would still be a reasonable conservative approximation. *) + + (* Check the region parameters *) + let regions = List.combine regions1 regions2 in + let params_b = + List.fold_left + (fun b (r1, r2) -> combine b (compare_regions r1 r2)) + default regions + in + (* Check the type parameters *) + let tys = List.combine tys1 tys2 in + let tys_b = + List.fold_left + (fun b (ty1, ty2) -> combine b (compare ty1 ty2)) + default tys + in + (* Combine *) + combine params_b tys_b + | T.Array ty1, T.Array ty2 | T.Slice ty1, T.Slice ty2 -> compare ty1 ty2 + | T.Ref (r1, ty1, kind1), T.Ref (r2, ty2, kind2) -> + (* Sanity check *) + assert (kind1 = kind2); + (* Explanation for the case where we check if projections intersect: + * the projections intersect if the borrows intersect or their contents + * intersect. *) + let regions_b = compare_regions r1 r2 in + let tys_b = compare ty1 ty2 in + combine regions_b tys_b + | T.TypeVar id1, T.TypeVar id2 -> + assert (id1 = id2); + default + | _ -> + log#lerror + (lazy + ("compare_rtys: unexpected inputs:" ^ "\n- ty1: " ^ T.show_rty ty1 + ^ "\n- ty2: " ^ T.show_rty ty2)); + failwith "Unreachable" + +(** Check if two different projections intersect. This is necessary when + giving a symbolic value to an abstraction: we need to check that + the regions which are already ended inside the abstraction don't + intersect the regions over which we project in the new abstraction. + Note that the two abstractions have different views (in terms of regions) + of the symbolic value (hence the two region types). +*) +let projections_intersect (ty1 : T.rty) (rset1 : T.RegionId.Set.t) (ty2 : T.rty) + (rset2 : T.RegionId.Set.t) : bool = + let default = false in + let combine b1 b2 = b1 || b2 in + let compare_regions r1 r2 = + region_in_set r1 rset1 && region_in_set r2 rset2 + in + compare_rtys default combine compare_regions ty1 ty2 + +(** Check if the first projection contains the second projection. + We use this function when checking invariants. +*) +let projection_contains (ty1 : T.rty) (rset1 : T.RegionId.Set.t) (ty2 : T.rty) + (rset2 : T.RegionId.Set.t) : bool = + let default = true in + let combine b1 b2 = b1 && b2 in + let compare_regions r1 r2 = + region_in_set r1 rset1 || not (region_in_set r2 rset2) + in + compare_rtys default combine compare_regions ty1 ty2 + +(** Lookup a loan content. + + The loan is referred to by a borrow id. + + TODO: group abs_or_var_id and g_loan_content. + *) +let lookup_loan_opt (ek : exploration_kind) (l : V.BorrowId.id) + (ctx : C.eval_ctx) : (abs_or_var_id * g_loan_content) option = + (* We store here whether we are inside an abstraction or a value - note that we + * could also track that with the environment, it would probably be more idiomatic + * and cleaner *) + let abs_or_var : abs_or_var_id option ref = ref None in + + let obj = + object + inherit [_] C.iter_eval_ctx as super + + method! visit_borrow_content env bc = + match bc with + | V.SharedBorrow (mv, bid) -> + (* Nothing specific to do *) + super#visit_SharedBorrow env mv bid + | V.InactivatedMutBorrow (mv, bid) -> + (* Nothing specific to do *) + super#visit_InactivatedMutBorrow env mv bid + | V.MutBorrow (bid, mv) -> + (* Control the dive *) + if ek.enter_mut_borrows then super#visit_MutBorrow env bid mv + else () + + (** We reimplement {!visit_Loan} (rather than the more precise functions + {!visit_SharedLoan}, etc.) on purpose: as we have an exhaustive match + below, we are more resilient to definition updates (the compiler + is our friend). + *) + method! visit_loan_content env lc = + match lc with + | V.SharedLoan (bids, sv) -> + (* Check if this is the loan we are looking for, and control the dive *) + if V.BorrowId.Set.mem l bids then + raise (FoundGLoanContent (Concrete lc)) + else if ek.enter_shared_loans then + super#visit_SharedLoan env bids sv + else () + | V.MutLoan bid -> + (* Check if this is the loan we are looking for *) + if bid = l then raise (FoundGLoanContent (Concrete lc)) + else super#visit_MutLoan env bid + + (** Note that we don't control diving inside the abstractions: if we + allow to dive inside abstractions, we allow to go anywhere + (because there are no use cases requiring finer control) *) + method! visit_aloan_content env lc = + match lc with + | V.AMutLoan (bid, av) -> + if bid = l then raise (FoundGLoanContent (Abstract lc)) + else super#visit_AMutLoan env bid av + | V.ASharedLoan (bids, v, av) -> + if V.BorrowId.Set.mem l bids then + raise (FoundGLoanContent (Abstract lc)) + else super#visit_ASharedLoan env bids v av + | V.AEndedMutLoan { given_back = _; child = _; given_back_meta = _ } + | V.AEndedSharedLoan (_, _) + | V.AIgnoredMutLoan (_, _) + | V.AEndedIgnoredMutLoan + { given_back = _; child = _; given_back_meta = _ } + | V.AIgnoredSharedLoan _ -> + super#visit_aloan_content env lc + + method! visit_Var env bv v = + assert (Option.is_none !abs_or_var); + abs_or_var := + Some + (VarId (match bv with Some bv -> Some bv.C.index | None -> None)); + super#visit_Var env bv v; + abs_or_var := None + + method! visit_Abs env abs = + assert (Option.is_none !abs_or_var); + if ek.enter_abs then ( + abs_or_var := Some (AbsId abs.V.abs_id); + super#visit_Abs env abs; + abs_or_var := None) + else () + end + in + (* We use exceptions *) + try + obj#visit_eval_ctx () ctx; + None + with FoundGLoanContent lc -> ( + match !abs_or_var with + | Some abs_or_var -> Some (abs_or_var, lc) + | None -> raise (Failure "Inconsistent state")) + +(** Lookup a loan content. + + The loan is referred to by a borrow id. + Raises an exception if no loan was found. + *) +let lookup_loan (ek : exploration_kind) (l : V.BorrowId.id) (ctx : C.eval_ctx) : + abs_or_var_id * g_loan_content = + match lookup_loan_opt ek l ctx with + | None -> failwith "Unreachable" + | Some res -> res + +(** Update a loan content. + + The loan is referred to by a borrow id. + + This is a helper function: it might break invariants. + *) +let update_loan (ek : exploration_kind) (l : V.BorrowId.id) + (nlc : V.loan_content) (ctx : C.eval_ctx) : C.eval_ctx = + (* We use a reference to check that we update exactly one loan: when updating + * inside values, we check we don't update more than one loan. Then, upon + * returning we check that we updated at least once. *) + let r = ref false in + let update () : V.loan_content = + assert (not !r); + r := true; + nlc + in + + let obj = + object + inherit [_] C.map_eval_ctx as super + + method! visit_borrow_content env bc = + match bc with + | V.SharedBorrow (_, _) | V.InactivatedMutBorrow _ -> + (* Nothing specific to do *) + super#visit_borrow_content env bc + | V.MutBorrow (bid, mv) -> + (* Control the dive into mutable borrows *) + if ek.enter_mut_borrows then super#visit_MutBorrow env bid mv + else V.MutBorrow (bid, mv) + + (** We reimplement {!visit_loan_content} (rather than one of the sub- + functions) on purpose: exhaustive matches are good for maintenance *) + method! visit_loan_content env lc = + match lc with + | V.SharedLoan (bids, sv) -> + (* Shared loan: check if this is the loan we are looking for, and + control the dive. *) + if V.BorrowId.Set.mem l bids then update () + else if ek.enter_shared_loans then + super#visit_SharedLoan env bids sv + else V.SharedLoan (bids, sv) + | V.MutLoan bid -> + (* Mut loan: checks if this is the loan we are looking for *) + if bid = l then update () else super#visit_MutLoan env bid + + (** Note that once inside the abstractions, we don't control diving + (there are no use cases requiring finer control). + Also, as we give back a {!loan_content} (and not an {!aloan_content}) + we don't need to do reimplement the visit functions for the values + inside the abstractions (rk.: there may be "concrete" values inside + abstractions, so there is a utility in diving inside). *) + method! visit_abs env abs = + if ek.enter_abs then super#visit_abs env abs else abs + end + in + + let ctx = obj#visit_eval_ctx () ctx in + (* Check that we updated at least one loan *) + assert !r; + ctx + +(** Update a abstraction loan content. + + The loan is referred to by a borrow id. + + This is a helper function: it might break invariants. + *) +let update_aloan (ek : exploration_kind) (l : V.BorrowId.id) + (nlc : V.aloan_content) (ctx : C.eval_ctx) : C.eval_ctx = + (* We use a reference to check that we update exactly one loan: when updating + * inside values, we check we don't update more than one loan. Then, upon + * returning we check that we updated at least once. *) + let r = ref false in + let update () : V.aloan_content = + assert (not !r); + r := true; + nlc + in + + let obj = + object + inherit [_] C.map_eval_ctx as super + + method! visit_aloan_content env lc = + match lc with + | V.AMutLoan (bid, av) -> + if bid = l then update () else super#visit_AMutLoan env bid av + | V.ASharedLoan (bids, v, av) -> + if V.BorrowId.Set.mem l bids then update () + else super#visit_ASharedLoan env bids v av + | V.AEndedMutLoan { given_back = _; child = _; given_back_meta = _ } + | V.AEndedSharedLoan (_, _) + | V.AIgnoredMutLoan (_, _) + | V.AEndedIgnoredMutLoan + { given_back = _; child = _; given_back_meta = _ } + | V.AIgnoredSharedLoan _ -> + super#visit_aloan_content env lc + + (** Note that once inside the abstractions, we don't control diving + (there are no use cases requiring finer control). *) + method! visit_abs env abs = + if ek.enter_abs then super#visit_abs env abs else abs + end + in + + let ctx = obj#visit_eval_ctx () ctx in + (* Check that we updated at least one loan *) + assert !r; + ctx + +(** Lookup a borrow content from a borrow id. *) +let lookup_borrow_opt (ek : exploration_kind) (l : V.BorrowId.id) + (ctx : C.eval_ctx) : g_borrow_content option = + let obj = + object + inherit [_] C.iter_eval_ctx as super + + method! visit_borrow_content env bc = + match bc with + | V.MutBorrow (bid, mv) -> + (* Check the borrow id and control the dive *) + if bid = l then raise (FoundGBorrowContent (Concrete bc)) + else if ek.enter_mut_borrows then super#visit_MutBorrow env bid mv + else () + | V.SharedBorrow (_, bid) -> + (* Check the borrow id *) + if bid = l then raise (FoundGBorrowContent (Concrete bc)) else () + | V.InactivatedMutBorrow (_, bid) -> + (* Check the borrow id *) + if bid = l then raise (FoundGBorrowContent (Concrete bc)) else () + + method! visit_loan_content env lc = + match lc with + | V.MutLoan bid -> + (* Nothing special to do *) super#visit_MutLoan env bid + | V.SharedLoan (bids, sv) -> + (* Control the dive *) + if ek.enter_shared_loans then super#visit_SharedLoan env bids sv + else () + + method! visit_aborrow_content env bc = + match bc with + | V.AMutBorrow (mv, bid, av) -> + if bid = l then raise (FoundGBorrowContent (Abstract bc)) + else super#visit_AMutBorrow env mv bid av + | V.ASharedBorrow bid -> + if bid = l then raise (FoundGBorrowContent (Abstract bc)) + else super#visit_ASharedBorrow env bid + | V.AIgnoredMutBorrow (_, _) + | V.AEndedMutBorrow _ + | V.AEndedIgnoredMutBorrow + { given_back_loans_proj = _; child = _; given_back_meta = _ } + | V.AEndedSharedBorrow -> + super#visit_aborrow_content env bc + | V.AProjSharedBorrow asb -> + if borrow_in_asb l asb then + raise (FoundGBorrowContent (Abstract bc)) + else () + + method! visit_abs env abs = + if ek.enter_abs then super#visit_abs env abs else () + end + in + (* We use exceptions *) + try + obj#visit_eval_ctx () ctx; + None + with FoundGBorrowContent lc -> Some lc + +(** Lookup a borrow content from a borrow id. + + Raise an exception if no loan was found +*) +let lookup_borrow (ek : exploration_kind) (l : V.BorrowId.id) (ctx : C.eval_ctx) + : g_borrow_content = + match lookup_borrow_opt ek l ctx with + | None -> failwith "Unreachable" + | Some lc -> lc + +(** Update a borrow content. + + The borrow is referred to by a borrow id. + + This is a helper function: it might break invariants. + *) +let update_borrow (ek : exploration_kind) (l : V.BorrowId.id) + (nbc : V.borrow_content) (ctx : C.eval_ctx) : C.eval_ctx = + (* We use a reference to check that we update exactly one borrow: when updating + * inside values, we check we don't update more than one borrow. Then, upon + * returning we check that we updated at least once. *) + let r = ref false in + let update () : V.borrow_content = + assert (not !r); + r := true; + nbc + in + + let obj = + object + inherit [_] C.map_eval_ctx as super + + method! visit_borrow_content env bc = + match bc with + | V.MutBorrow (bid, mv) -> + (* Check the id and control dive *) + if bid = l then update () + else if ek.enter_mut_borrows then super#visit_MutBorrow env bid mv + else V.MutBorrow (bid, mv) + | V.SharedBorrow (mv, bid) -> + (* Check the id *) + if bid = l then update () else super#visit_SharedBorrow env mv bid + | V.InactivatedMutBorrow (mv, bid) -> + (* Check the id *) + if bid = l then update () + else super#visit_InactivatedMutBorrow env mv bid + + method! visit_loan_content env lc = + match lc with + | V.SharedLoan (bids, sv) -> + (* Control the dive *) + if ek.enter_shared_loans then super#visit_SharedLoan env bids sv + else V.SharedLoan (bids, sv) + | V.MutLoan bid -> + (* Nothing specific to do *) + super#visit_MutLoan env bid + + method! visit_abs env abs = + if ek.enter_abs then super#visit_abs env abs else abs + end + in + + let ctx = obj#visit_eval_ctx () ctx in + (* Check that we updated at least one borrow *) + assert !r; + ctx + +(** Update an abstraction borrow content. + + The borrow is referred to by a borrow id. + + This is a helper function: it might break invariants. + *) +let update_aborrow (ek : exploration_kind) (l : V.BorrowId.id) (nv : V.avalue) + (ctx : C.eval_ctx) : C.eval_ctx = + (* We use a reference to check that we update exactly one borrow: when updating + * inside values, we check we don't update more than one borrow. Then, upon + * returning we check that we updated at least once. *) + let r = ref false in + let update () : V.avalue = + assert (not !r); + r := true; + nv + in + + let obj = + object + inherit [_] C.map_eval_ctx as super + + method! visit_ABorrow env bc = + match bc with + | V.AMutBorrow (mv, bid, av) -> + if bid = l then update () + else V.ABorrow (super#visit_AMutBorrow env mv bid av) + | V.ASharedBorrow bid -> + if bid = l then update () + else V.ABorrow (super#visit_ASharedBorrow env bid) + | V.AIgnoredMutBorrow _ | V.AEndedMutBorrow _ | V.AEndedSharedBorrow + | V.AEndedIgnoredMutBorrow _ -> + super#visit_ABorrow env bc + | V.AProjSharedBorrow asb -> + if borrow_in_asb l asb then update () + else V.ABorrow (super#visit_AProjSharedBorrow env asb) + + method! visit_abs env abs = + if ek.enter_abs then super#visit_abs env abs else abs + end + in + + let ctx = obj#visit_eval_ctx () ctx in + (* Check that we updated at least one borrow *) + assert !r; + ctx + +(** Auxiliary function: see its usage in [end_borrow_get_borrow_in_value] *) +let update_outer_borrows (outer : V.AbstractionId.id option * borrow_ids option) + (x : borrow_ids) : V.AbstractionId.id option * borrow_ids option = + let abs, opt = outer in + (abs, update_if_none opt x) + +(** Return the first loan we find in a value *) +let get_first_loan_in_value (v : V.typed_value) : V.loan_content option = + let obj = + object + inherit [_] V.iter_typed_value + method! visit_loan_content _ lc = raise (FoundLoanContent lc) + end + in + (* We use exceptions *) + try + obj#visit_typed_value () v; + None + with FoundLoanContent lc -> Some lc + +(** Return the first borrow we find in a value *) +let get_first_borrow_in_value (v : V.typed_value) : V.borrow_content option = + let obj = + object + inherit [_] V.iter_typed_value + method! visit_borrow_content _ bc = raise (FoundBorrowContent bc) + end + in + (* We use exceptions *) + try + obj#visit_typed_value () v; + None + with FoundBorrowContent bc -> Some bc + +(** Return the first loan or borrow content we find in a value (starting with + the outer ones). + + [with_borrows]: + - if true: return the first loan or borrow we find + - if false: return the first loan we find, do not dive into borrowed values + *) +let get_first_outer_loan_or_borrow_in_value (with_borrows : bool) + (v : V.typed_value) : loan_or_borrow_content option = + let obj = + object + inherit [_] V.iter_typed_value + + method! visit_borrow_content _ bc = + if with_borrows then raise (FoundBorrowContent bc) else () + + method! visit_loan_content _ lc = raise (FoundLoanContent lc) + end + in + (* We use exceptions *) + try + obj#visit_typed_value () v; + None + with + | FoundLoanContent lc -> Some (LoanContent lc) + | FoundBorrowContent bc -> Some (BorrowContent bc) + +type gproj_borrows = + | AProjBorrows of V.AbstractionId.id * V.symbolic_value + | ProjBorrows of V.symbolic_value + +let proj_borrows_intersects_proj_loans + (proj_borrows : T.RegionId.Set.t * V.symbolic_value * T.rty) + (proj_loans : T.RegionId.Set.t * V.symbolic_value) : bool = + let b_regions, b_sv, b_ty = proj_borrows in + let l_regions, l_sv = proj_loans in + if same_symbolic_id b_sv l_sv then + projections_intersect l_sv.V.sv_ty l_regions b_ty b_regions + else false + +(** Result of looking up aproj_borrows which intersect a given aproj_loans in + the context. + + Note that because we we force the expansion of primitively copyable values + before giving them to abstractions, we only have the following possibilities: + - no aproj_borrows, in which case the symbolic value was either dropped + or is in the context + - exactly one aproj_borrows over a non-shared value + - potentially several aproj_borrows over shared values + + The result contains the ids of the abstractions in which the projectors were + found, as well as the projection types used in those abstractions. +*) +type looked_up_aproj_borrows = + | NonSharedProj of V.AbstractionId.id * T.rty + | SharedProjs of (V.AbstractionId.id * T.rty) list + +(** Lookup the aproj_borrows (including aproj_shared_borrows) over a + symbolic value which intersect a given set of regions. + + [lookup_shared]: if [true] also explore projectors over shared values, + otherwise ignore. + + This is a helper function. +*) +let lookup_intersecting_aproj_borrows_opt (lookup_shared : bool) + (regions : T.RegionId.Set.t) (sv : V.symbolic_value) (ctx : C.eval_ctx) : + looked_up_aproj_borrows option = + let found : looked_up_aproj_borrows option ref = ref None in + let set_non_shared ((id, ty) : V.AbstractionId.id * T.rty) : unit = + match !found with + | None -> found := Some (NonSharedProj (id, ty)) + | Some _ -> failwith "Unreachable" + in + let add_shared (x : V.AbstractionId.id * T.rty) : unit = + match !found with + | None -> found := Some (SharedProjs [ x ]) + | Some (SharedProjs pl) -> found := Some (SharedProjs (x :: pl)) + | Some (NonSharedProj _) -> failwith "Unreachable" + in + let check_add_proj_borrows (is_shared : bool) abs sv' proj_ty = + if + proj_borrows_intersects_proj_loans + (abs.V.regions, sv', proj_ty) + (regions, sv) + then + let x = (abs.abs_id, proj_ty) in + if is_shared then add_shared x else set_non_shared x + else () + in + let obj = + object + inherit [_] C.iter_eval_ctx as super + method! visit_abs _ abs = super#visit_abs (Some abs) abs + + method! visit_abstract_shared_borrows abs asb = + (* Sanity check *) + (match !found with + | Some (NonSharedProj _) -> failwith "Unreachable" + | _ -> ()); + (* Explore *) + if lookup_shared then + let abs = Option.get abs in + let check asb = + match asb with + | V.AsbBorrow _ -> () + | V.AsbProjReborrows (sv', proj_ty) -> + let is_shared = true in + check_add_proj_borrows is_shared abs sv' proj_ty + in + List.iter check asb + else () + + method! visit_aproj abs sproj = + (let abs = Option.get abs in + match sproj with + | AProjLoans _ | AEndedProjLoans _ | AEndedProjBorrows _ + | AIgnoredProjBorrows -> + () + | AProjBorrows (sv', proj_rty) -> + let is_shared = false in + check_add_proj_borrows is_shared abs sv' proj_rty); + super#visit_aproj abs sproj + end + in + (* Visit *) + obj#visit_eval_ctx None ctx; + (* Return *) + !found + +(** Lookup the aproj_borrows (not aproj_borrows_shared!) over a symbolic + value which intersects a given set of regions. + + Note that there should be **at most one** (one reason is that we force + the expansion of primitively copyable values before giving them to + abstractions). + + Returns the id of the owning abstraction, and the projection type used in + this abstraction. +*) +let lookup_intersecting_aproj_borrows_not_shared_opt + (regions : T.RegionId.Set.t) (sv : V.symbolic_value) (ctx : C.eval_ctx) : + (V.AbstractionId.id * T.rty) option = + let lookup_shared = false in + match lookup_intersecting_aproj_borrows_opt lookup_shared regions sv ctx with + | None -> None + | Some (NonSharedProj (abs_id, rty)) -> Some (abs_id, rty) + | _ -> failwith "Unexpected" + +(** Similar to {!lookup_intersecting_aproj_borrows_opt}, but updates the + values. + + This is a helper function: it might break invariants. + *) +let update_intersecting_aproj_borrows (can_update_shared : bool) + (update_shared : V.AbstractionId.id -> T.rty -> V.abstract_shared_borrows) + (update_non_shared : V.AbstractionId.id -> T.rty -> V.aproj) + (regions : T.RegionId.Set.t) (sv : V.symbolic_value) (ctx : C.eval_ctx) : + C.eval_ctx = + (* Small helpers for sanity checks *) + let shared = ref None in + let add_shared () = + match !shared with None -> shared := Some true | Some b -> assert b + in + let set_non_shared () = + match !shared with + | None -> shared := Some false + | Some _ -> failwith "Found unexpected intersecting proj_borrows" + in + let check_proj_borrows is_shared abs sv' proj_ty = + if + proj_borrows_intersects_proj_loans + (abs.V.regions, sv', proj_ty) + (regions, sv) + then ( + if is_shared then add_shared () else set_non_shared (); + true) + else false + in + (* The visitor *) + let obj = + object + inherit [_] C.map_eval_ctx as super + method! visit_abs _ abs = super#visit_abs (Some abs) abs + + method! visit_abstract_shared_borrows abs asb = + (* Sanity check *) + (match !shared with Some b -> assert b | _ -> ()); + (* Explore *) + if can_update_shared then + let abs = Option.get abs in + let update (asb : V.abstract_shared_borrow) : + V.abstract_shared_borrows = + match asb with + | V.AsbBorrow _ -> [ asb ] + | V.AsbProjReborrows (sv', proj_ty) -> + let is_shared = true in + if check_proj_borrows is_shared abs sv' proj_ty then + update_shared abs.abs_id proj_ty + else [ asb ] + in + List.concat (List.map update asb) + else asb + + method! visit_aproj abs sproj = + match sproj with + | AProjLoans _ | AEndedProjLoans _ | AEndedProjBorrows _ + | AIgnoredProjBorrows -> + super#visit_aproj abs sproj + | AProjBorrows (sv', proj_rty) -> + let abs = Option.get abs in + let is_shared = true in + if check_proj_borrows is_shared abs sv' proj_rty then + update_non_shared abs.abs_id proj_rty + else super#visit_aproj (Some abs) sproj + end + in + (* Apply *) + let ctx = obj#visit_eval_ctx None ctx in + (* Check that we updated the context at least once *) + assert (Option.is_some !shared); + (* Return *) + ctx + +(** Simply calls {!update_intersecting_aproj_borrows} to update a + proj_borrows over a non-shared value. + + We check that we update *at least* one proj_borrows. + + This is a helper function: it might break invariants. + *) +let update_intersecting_aproj_borrows_non_shared (regions : T.RegionId.Set.t) + (sv : V.symbolic_value) (nv : V.aproj) (ctx : C.eval_ctx) : C.eval_ctx = + (* Small helpers *) + let can_update_shared = false in + let update_shared _ _ = failwith "Unexpected" in + let updated = ref false in + let update_non_shared _ _ = + (* We can update more than one borrow! *) + updated := true; + nv + in + (* Update *) + let ctx = + update_intersecting_aproj_borrows can_update_shared update_shared + update_non_shared regions sv ctx + in + (* Check that we updated at least once *) + assert !updated; + (* Return *) + ctx + +(** Simply calls {!update_intersecting_aproj_borrows} to remove the + proj_borrows over shared values. + + This is a helper function: it might break invariants. + *) +let remove_intersecting_aproj_borrows_shared (regions : T.RegionId.Set.t) + (sv : V.symbolic_value) (ctx : C.eval_ctx) : C.eval_ctx = + (* Small helpers *) + let can_update_shared = true in + let update_shared _ _ = [] in + let update_non_shared _ _ = failwith "Unexpected" in + (* Update *) + update_intersecting_aproj_borrows can_update_shared update_shared + update_non_shared regions sv ctx + +(** Updates the proj_loans intersecting some projection. + + This is a helper function: it might break invariants. + + Note that we can update more than one projector of loans! Consider the + following example: + {[ + fn f<'a, 'b>(...) -> (&'a mut u32, &'b mut u32)); + fn g<'c>(&'c mut u32, &'c mut u32); + + let p = f(...); + g(move p); + + // Symbolic context after the call to g: + // abs'a {'a} { [s@0 <: (&'a mut u32, &'b mut u32)] } + // abs'b {'b} { [s@0 <: (&'a mut u32, &'b mut u32)] } + // + // abs'c {'c} { (s@0 <: (&'c mut u32, &'c mut u32)) } + ]} + + Note that for sanity, this function checks that we update *at least* one + projector of loans. + + [subst]: takes as parameters the abstraction in which we perform the + substitution and the list of given back values at the projector of + loans where we perform the substitution (see the fields in {!V.AProjLoans}). + Note that the symbolic value at this place is necessarily equal to [sv], + which is why we don't give it as parameters. + *) +let update_intersecting_aproj_loans (proj_regions : T.RegionId.Set.t) + (proj_ty : T.rty) (sv : V.symbolic_value) + (subst : V.abs -> (V.msymbolic_value * V.aproj) list -> V.aproj) + (ctx : C.eval_ctx) : C.eval_ctx = + (* Small helpers for sanity checks *) + let updated = ref false in + let update abs local_given_back : V.aproj = + (* Note that we can update more than once! *) + updated := true; + subst abs local_given_back + in + (* The visitor *) + let obj = + object + inherit [_] C.map_eval_ctx as super + method! visit_abs _ abs = super#visit_abs (Some abs) abs + + method! visit_aproj abs sproj = + match sproj with + | AProjBorrows _ | AEndedProjLoans _ | AEndedProjBorrows _ + | AIgnoredProjBorrows -> + super#visit_aproj abs sproj + | AProjLoans (sv', given_back) -> + let abs = Option.get abs in + if same_symbolic_id sv sv' then ( + assert (sv.sv_ty = sv'.sv_ty); + if + projections_intersect proj_ty proj_regions sv'.V.sv_ty + abs.regions + then update abs given_back + else super#visit_aproj (Some abs) sproj) + else super#visit_aproj (Some abs) sproj + end + in + (* Apply *) + let ctx = obj#visit_eval_ctx None ctx in + (* Check that we updated the context at least once *) + assert !updated; + (* Return *) + ctx + +(** Helper function: lookup an {!V.AProjLoans} by using an abstraction id and a + symbolic value. + + We return the information from the looked up projector of loans. See the + fields in {!V.AProjLoans} (we don't return the symbolic value, because it + is equal to [sv]). + + Sanity check: we check that there is exactly one projector which corresponds + to the couple (abstraction id, symbolic value). + *) +let lookup_aproj_loans (abs_id : V.AbstractionId.id) (sv : V.symbolic_value) + (ctx : C.eval_ctx) : (V.msymbolic_value * V.aproj) list = + (* Small helpers for sanity checks *) + let found = ref None in + let set_found x = + (* There is at most one projector which corresponds to the description *) + assert (Option.is_none !found); + found := Some x + in + (* The visitor *) + let obj = + object + inherit [_] C.iter_eval_ctx as super + + method! visit_abs _ abs = + if abs.abs_id = abs_id then super#visit_abs (Some abs) abs else () + + method! visit_aproj (abs : V.abs option) sproj = + (match sproj with + | AProjBorrows _ | AEndedProjLoans _ | AEndedProjBorrows _ + | AIgnoredProjBorrows -> + super#visit_aproj abs sproj + | AProjLoans (sv', given_back) -> + let abs = Option.get abs in + assert (abs.abs_id = abs_id); + if sv'.sv_id = sv.sv_id then ( + assert (sv' = sv); + set_found given_back) + else ()); + super#visit_aproj abs sproj + end + in + (* Apply *) + obj#visit_eval_ctx None ctx; + (* Return *) + Option.get !found + +(** Helper function: might break invariants. + + Update a projector over loans. The projector is identified by a symbolic + value and an abstraction id. + + Sanity check: we check that there is exactly one projector which corresponds + to the couple (abstraction id, symbolic value). + *) +let update_aproj_loans (abs_id : V.AbstractionId.id) (sv : V.symbolic_value) + (nproj : V.aproj) (ctx : C.eval_ctx) : C.eval_ctx = + (* Small helpers for sanity checks *) + let found = ref false in + let update () = + (* We update at most once *) + assert (not !found); + found := true; + nproj + in + (* The visitor *) + let obj = + object + inherit [_] C.map_eval_ctx as super + + method! visit_abs _ abs = + if abs.abs_id = abs_id then super#visit_abs (Some abs) abs else abs + + method! visit_aproj (abs : V.abs option) sproj = + match sproj with + | AProjBorrows _ | AEndedProjLoans _ | AEndedProjBorrows _ + | AIgnoredProjBorrows -> + super#visit_aproj abs sproj + | AProjLoans (sv', _) -> + let abs = Option.get abs in + assert (abs.abs_id = abs_id); + if sv'.sv_id = sv.sv_id then ( + assert (sv' = sv); + update ()) + else super#visit_aproj (Some abs) sproj + end + in + (* Apply *) + let ctx = obj#visit_eval_ctx None ctx in + (* Sanity check *) + assert !found; + (* Return *) + ctx + +(** Helper function: might break invariants. + + Update a projector over borrows. The projector is identified by a symbolic + value and an abstraction id. + + Sanity check: we check that there is exactly one projector which corresponds + to the couple (abstraction id, symbolic value). + + TODO: factorize with {!update_aproj_loans}? + *) +let update_aproj_borrows (abs_id : V.AbstractionId.id) (sv : V.symbolic_value) + (nproj : V.aproj) (ctx : C.eval_ctx) : C.eval_ctx = + (* Small helpers for sanity checks *) + let found = ref false in + let update () = + (* We update at most once *) + assert (not !found); + found := true; + nproj + in + (* The visitor *) + let obj = + object + inherit [_] C.map_eval_ctx as super + + method! visit_abs _ abs = + if abs.abs_id = abs_id then super#visit_abs (Some abs) abs else abs + + method! visit_aproj (abs : V.abs option) sproj = + match sproj with + | AProjLoans _ | AEndedProjLoans _ | AEndedProjBorrows _ + | AIgnoredProjBorrows -> + super#visit_aproj abs sproj + | AProjBorrows (sv', _proj_ty) -> + let abs = Option.get abs in + assert (abs.abs_id = abs_id); + if sv'.sv_id = sv.sv_id then ( + assert (sv' = sv); + update ()) + else super#visit_aproj (Some abs) sproj + end + in + (* Apply *) + let ctx = obj#visit_eval_ctx None ctx in + (* Sanity check *) + assert !found; + (* Return *) + ctx + +(** Helper function: might break invariants. + + Converts an {!V.AProjLoans} to an {!V.AEndedProjLoans}. The projector is identified + by a symbolic value and an abstraction id. + *) +let update_aproj_loans_to_ended (abs_id : V.AbstractionId.id) + (sv : V.symbolic_value) (ctx : C.eval_ctx) : C.eval_ctx = + (* Lookup the projector of loans *) + let given_back = lookup_aproj_loans abs_id sv ctx in + (* Create the new value for the projector *) + let nproj = V.AEndedProjLoans (sv, given_back) in + (* Insert it *) + let ctx = update_aproj_loans abs_id sv nproj ctx in + (* Return *) + ctx + +let no_aproj_over_symbolic_in_context (sv : V.symbolic_value) (ctx : C.eval_ctx) + : unit = + (* The visitor *) + let obj = + object + inherit [_] C.iter_eval_ctx as super + + method! visit_aproj env sproj = + (match sproj with + | AEndedProjLoans _ | AEndedProjBorrows _ | AIgnoredProjBorrows -> () + | AProjLoans (sv', _) | AProjBorrows (sv', _) -> + if sv'.sv_id = sv.sv_id then raise Found else ()); + super#visit_aproj env sproj + end + in + (* Apply *) + try obj#visit_eval_ctx () ctx + with Found -> failwith "update_aproj_loans_to_ended: failed" + +(** Helper function + + Return the loan (aloan, loan, proj_loans over a symbolic value) we find + in an abstraction, if there is. + + **Remark:** we don't take the *ignored* mut/shared loans into account. + *) +let get_first_non_ignored_aloan_in_abstraction (abs : V.abs) : + borrow_ids_or_symbolic_value option = + (* Explore to find a loan *) + let obj = + object + inherit [_] V.iter_abs as super + + method! visit_aloan_content env lc = + match lc with + | V.AMutLoan (bid, _) -> raise (FoundBorrowIds (Borrow bid)) + | V.ASharedLoan (bids, _, _) -> raise (FoundBorrowIds (Borrows bids)) + | V.AEndedMutLoan { given_back = _; child = _; given_back_meta = _ } + | V.AEndedSharedLoan (_, _) -> + super#visit_aloan_content env lc + | V.AIgnoredMutLoan (_, _) -> + (* Ignore *) + super#visit_aloan_content env lc + | V.AEndedIgnoredMutLoan + { given_back = _; child = _; given_back_meta = _ } + | V.AIgnoredSharedLoan _ -> + (* Ignore *) + super#visit_aloan_content env lc + + (** We may need to visit loan contents because of shared values *) + method! visit_loan_content _ lc = + match lc with + | V.MutLoan _ -> + (* The mut loan linked to the mutable borrow present in a shared + * value in an abstraction should be in an AProjBorrows *) + failwith "Unreachable" + | V.SharedLoan (bids, _) -> raise (FoundBorrowIds (Borrows bids)) + + method! visit_aproj env sproj = + (match sproj with + | V.AProjBorrows (_, _) + | V.AEndedProjLoans _ | V.AEndedProjBorrows _ | V.AIgnoredProjBorrows -> + () + | V.AProjLoans (sv, _) -> raise (ValuesUtils.FoundSymbolicValue sv)); + super#visit_aproj env sproj + end + in + try + (* Check if there are loans *) + obj#visit_abs () abs; + (* No loans *) + None + with + (* There are loans *) + | FoundBorrowIds bids -> Some (BorrowIds bids) + | ValuesUtils.FoundSymbolicValue sv -> + (* There are loan projections over symbolic values *) + Some (SymbolicValue sv) diff --git a/compiler/InterpreterExpansion.ml b/compiler/InterpreterExpansion.ml new file mode 100644 index 00000000..0ca34b43 --- /dev/null +++ b/compiler/InterpreterExpansion.ml @@ -0,0 +1,733 @@ +(* This module provides the functions which handle expansion of symbolic values. + * For now, this file doesn't handle expansion of ⊥ values because they need + * some path utilities for replacement. We might change that in the future (by + * using indices to identify the values for instance). *) + +module T = Types +module V = Values +module E = Expressions +module C = Contexts +module Subst = Substitute +module L = Logging +open TypesUtils +module Inv = Invariants +module S = SynthesizeSymbolic +module SA = SymbolicAst +open Cps +open ValuesUtils +open InterpreterUtils +open InterpreterProjectors +open InterpreterBorrows + +(** The local logger *) +let log = L.expansion_log + +(** Projector kind *) +type proj_kind = LoanProj | BorrowProj + +(** Auxiliary function. + Apply a symbolic expansion to avalues in a context, targetting a specific + kind of projectors. + + [proj_kind] controls whether we apply the expansion to projectors + on loans or projectors on borrows. + + When dealing with reference expansion, it is necessary to first apply the + expansion on loan projectors, then on borrow projectors. The reason is + that reducing the borrow projectors might require to perform some reborrows, + in which case we need to lookup the corresponding loans in the context. + + [allow_reborrows] controls whether we allow reborrows or not. It is useful + only if we target borrow projectors. + + Also, if this function is called on an expansion for *shared references*, + the proj borrows should already have been expanded. + + TODO: the way this function is used is a bit complex, especially because of + the above condition. Maybe we should have: + 1. a generic function to expand the loan projectors + 2. a function to expand the borrow projectors for non-borrows + 3. specialized functions for mut borrows and shared borrows + Note that 2. and 3. may have a little bit of duplicated code, but hopefully + it would make things clearer. +*) +let apply_symbolic_expansion_to_target_avalues (config : C.config) + (allow_reborrows : bool) (proj_kind : proj_kind) + (original_sv : V.symbolic_value) (expansion : V.symbolic_expansion) + (ctx : C.eval_ctx) : C.eval_ctx = + (* Symbolic values contained in the expansion might contain already ended regions *) + let check_symbolic_no_ended = false in + (* Prepare reborrows registration *) + let fresh_reborrow, apply_registered_reborrows = + prepare_reborrows config allow_reborrows + in + (* Visitor to apply the expansion *) + let obj = + object (self) + inherit [_] C.map_eval_ctx as super + + (** When visiting an abstraction, we remember the regions it owns to be + able to properly reduce projectors when expanding symbolic values *) + method! visit_abs current_abs abs = + assert (Option.is_none current_abs); + let current_abs = Some abs in + super#visit_abs current_abs abs + + (** We carefully updated {!visit_ASymbolic} so that {!visit_aproj} is called + only on child projections (i.e., projections which appear in {!AEndedProjLoans}). + The role of visit_aproj is then to check we don't have to expand symbolic + values in child projections, because it should never happen + *) + method! visit_aproj current_abs aproj = + (match aproj with + | AProjLoans (sv, _) | AProjBorrows (sv, _) -> + assert (not (same_symbolic_id sv original_sv)) + | AEndedProjLoans _ | AEndedProjBorrows _ | AIgnoredProjBorrows -> ()); + super#visit_aproj current_abs aproj + + method! visit_ASymbolic current_abs aproj = + let current_abs = Option.get current_abs in + let proj_regions = current_abs.regions in + let ancestors_regions = current_abs.ancestors_regions in + (* Explore in depth first - we won't update anything: we simply + * want to check we don't have to expand inner symbolic value *) + match (aproj, proj_kind) with + | V.AEndedProjBorrows _, _ -> V.ASymbolic aproj + | V.AEndedProjLoans _, _ -> + (* Explore the given back values to make sure we don't have to expand + * anything in there *) + V.ASymbolic (self#visit_aproj (Some current_abs) aproj) + | V.AProjLoans (sv, given_back), LoanProj -> + (* Check if this is the symbolic value we are looking for *) + if same_symbolic_id sv original_sv then ( + (* There mustn't be any given back values *) + assert (given_back = []); + (* Apply the projector *) + let projected_value = + apply_proj_loans_on_symbolic_expansion proj_regions expansion + original_sv.V.sv_ty + in + (* Replace *) + projected_value.V.value) + else + (* Not the searched symbolic value: nothing to do *) + super#visit_ASymbolic (Some current_abs) aproj + | V.AProjBorrows (sv, proj_ty), BorrowProj -> + (* Check if this is the symbolic value we are looking for *) + if same_symbolic_id sv original_sv then + (* Convert the symbolic expansion to a value on which we can + * apply a projector (if the expansion is a reference expansion, + * convert it to a borrow) *) + (* WARNING: we mustn't get there if the expansion is for a shared + * reference. *) + let expansion = + symbolic_expansion_non_shared_borrow_to_value original_sv + expansion + in + (* Apply the projector *) + let projected_value = + apply_proj_borrows check_symbolic_no_ended ctx fresh_reborrow + proj_regions ancestors_regions expansion proj_ty + in + (* Replace *) + projected_value.V.value + else + (* Not the searched symbolic value: nothing to do *) + super#visit_ASymbolic (Some current_abs) aproj + | V.AProjLoans _, BorrowProj + | V.AProjBorrows (_, _), LoanProj + | V.AIgnoredProjBorrows, _ -> + (* Nothing to do *) + V.ASymbolic aproj + end + in + (* Apply the expansion *) + let ctx = obj#visit_eval_ctx None ctx in + (* Apply the reborrows *) + apply_registered_reborrows ctx + +(** Auxiliary function. + Apply a symbolic expansion to avalues in a context. +*) +let apply_symbolic_expansion_to_avalues (config : C.config) + (allow_reborrows : bool) (original_sv : V.symbolic_value) + (expansion : V.symbolic_expansion) (ctx : C.eval_ctx) : C.eval_ctx = + let apply_expansion proj_kind ctx = + apply_symbolic_expansion_to_target_avalues config allow_reborrows proj_kind + original_sv expansion ctx + in + (* First target the loan projectors, then the borrow projectors *) + let ctx = apply_expansion LoanProj ctx in + let ctx = apply_expansion BorrowProj ctx in + ctx + +(** Auxiliary function. + + Simply replace the symbolic values (*not avalues*) in the context with + a given value. Will break invariants if not used properly. +*) +let replace_symbolic_values (at_most_once : bool) + (original_sv : V.symbolic_value) (nv : V.value) (ctx : C.eval_ctx) : + C.eval_ctx = + (* Count *) + let replaced = ref false in + let replace () = + if at_most_once then assert (not !replaced); + replaced := true; + nv + in + (* Visitor to apply the substitution *) + let obj = + object + inherit [_] C.map_eval_ctx as super + + method! visit_Symbolic env spc = + if same_symbolic_id spc original_sv then replace () + else super#visit_Symbolic env spc + end + in + (* Apply the substitution *) + let ctx = obj#visit_eval_ctx None ctx in + (* Return *) + ctx + +(** Apply a symbolic expansion to a context, by replacing the original + symbolic value with its expanded value. Is valid only if the expansion + is not a borrow (i.e., an adt...). + + This function does update the synthesis. +*) +let apply_symbolic_expansion_non_borrow (config : C.config) + (original_sv : V.symbolic_value) (expansion : V.symbolic_expansion) + (ctx : C.eval_ctx) : C.eval_ctx = + (* Apply the expansion to non-abstraction values *) + let nv = symbolic_expansion_non_borrow_to_value original_sv expansion in + let at_most_once = false in + let ctx = replace_symbolic_values at_most_once original_sv nv.V.value ctx in + (* Apply the expansion to abstraction values *) + let allow_reborrows = false in + apply_symbolic_expansion_to_avalues config allow_reborrows original_sv + expansion ctx + +(** Compute the expansion of an adt value. + + The function might return a list of values if the symbolic value to expand + is an enumeration. + + [expand_enumerations] controls the expansion of enumerations: if false, it + doesn't allow the expansion of enumerations *containing several variants*. + *) +let compute_expanded_symbolic_adt_value (expand_enumerations : bool) + (kind : V.sv_kind) (def_id : T.TypeDeclId.id) + (regions : T.RegionId.id T.region list) (types : T.rty list) + (ctx : C.eval_ctx) : V.symbolic_expansion list = + (* Lookup the definition and check if it is an enumeration with several + * variants *) + let def = C.ctx_lookup_type_decl ctx def_id in + assert (List.length regions = List.length def.T.region_params); + (* Retrieve, for every variant, the list of its instantiated field types *) + let variants_fields_types = + Subst.type_decl_get_instantiated_variants_fields_rtypes def regions types + in + (* Check if there is strictly more than one variant *) + if List.length variants_fields_types > 1 && not expand_enumerations then + raise (Failure "Not allowed to expand enumerations with several variants"); + (* Initialize the expanded value for a given variant *) + let initialize + ((variant_id, field_types) : T.VariantId.id option * T.rty list) : + V.symbolic_expansion = + let field_values = + List.map (fun (ty : T.rty) -> mk_fresh_symbolic_value kind ty) field_types + in + let see = V.SeAdt (variant_id, field_values) in + see + in + (* Initialize all the expanded values of all the variants *) + List.map initialize variants_fields_types + +(** Compute the expansion of an Option value. + *) +let compute_expanded_symbolic_option_value (expand_enumerations : bool) + (kind : V.sv_kind) (ty : T.rty) : V.symbolic_expansion list = + assert expand_enumerations; + let some_se = + V.SeAdt (Some T.option_some_id, [ mk_fresh_symbolic_value kind ty ]) + in + let none_se = V.SeAdt (Some T.option_none_id, []) in + [ none_se; some_se ] + +let compute_expanded_symbolic_tuple_value (kind : V.sv_kind) + (field_types : T.rty list) : V.symbolic_expansion = + (* Generate the field values *) + let field_values = + List.map (fun sv_ty -> mk_fresh_symbolic_value kind sv_ty) field_types + in + let variant_id = None in + let see = V.SeAdt (variant_id, field_values) in + see + +let compute_expanded_symbolic_box_value (kind : V.sv_kind) (boxed_ty : T.rty) : + V.symbolic_expansion = + (* Introduce a fresh symbolic value *) + let boxed_value = mk_fresh_symbolic_value kind boxed_ty in + let see = V.SeAdt (None, [ boxed_value ]) in + see + +let expand_symbolic_value_shared_borrow (config : C.config) + (original_sv : V.symbolic_value) (original_sv_place : SA.mplace option) + (ref_ty : T.rty) : cm_fun = + fun cf ctx -> + (* First, replace the projectors on borrows. + * The important point is that the symbolic value to expand may appear + * several times, if it has been copied. In this case, we need to introduce + * one fresh borrow id per instance. + *) + let borrows = ref V.BorrowId.Set.empty in + let fresh_borrow () = + let bid' = C.fresh_borrow_id () in + borrows := V.BorrowId.Set.add bid' !borrows; + bid' + in + (* Small utility used on shared borrows in abstractions (regular borrow + * projector and asb). + * Returns [Some] if the symbolic value has been expanded to an asb list, + * [None] otherwise *) + let reborrow_ashared proj_regions (sv : V.symbolic_value) (proj_ty : T.rty) : + V.abstract_shared_borrows option = + if same_symbolic_id sv original_sv then + match proj_ty with + | T.Ref (r, ref_ty, T.Shared) -> + (* Projector over the shared value *) + let shared_asb = V.AsbProjReborrows (sv, ref_ty) in + (* Check if the region is in the set of projected regions *) + if region_in_set r proj_regions then + (* In the set: we need to reborrow *) + let bid = fresh_borrow () in + Some [ V.AsbBorrow bid; shared_asb ] + else (* Not in the set: ignore *) + Some [ shared_asb ] + | _ -> raise (Failure "Unexpected") + else None + in + (* The fresh symbolic value for the shared value *) + let shared_sv = mk_fresh_symbolic_value original_sv.sv_kind ref_ty in + (* Visitor to replace the projectors on borrows *) + let obj = + object (self) + inherit [_] C.map_eval_ctx as super + + method! visit_Symbolic env sv = + if same_symbolic_id sv original_sv then + let bid = fresh_borrow () in + V.Borrow + (V.SharedBorrow (mk_typed_value_from_symbolic_value shared_sv, bid)) + else super#visit_Symbolic env sv + + method! visit_Abs proj_regions abs = + assert (Option.is_none proj_regions); + let proj_regions = Some abs.V.regions in + super#visit_Abs proj_regions abs + + method! visit_AProjSharedBorrow proj_regions asb = + let expand_asb (asb : V.abstract_shared_borrow) : + V.abstract_shared_borrows = + match asb with + | V.AsbBorrow _ -> [ asb ] + | V.AsbProjReborrows (sv, proj_ty) -> ( + match reborrow_ashared (Option.get proj_regions) sv proj_ty with + | None -> [ asb ] + | Some asb -> asb) + in + let asb = List.concat (List.map expand_asb asb) in + V.AProjSharedBorrow asb + + (** We carefully updated {!visit_ASymbolic} so that {!visit_aproj} is called + only on child projections (i.e., projections which appear in {!AEndedProjLoans}). + The role of visit_aproj is then to check we don't have to expand symbolic + values in child projections, because it should never happen + *) + method! visit_aproj proj_regions aproj = + (match aproj with + | AProjLoans (sv, _) | AProjBorrows (sv, _) -> + assert (not (same_symbolic_id sv original_sv)) + | AEndedProjLoans _ | AEndedProjBorrows _ | AIgnoredProjBorrows -> ()); + super#visit_aproj proj_regions aproj + + method! visit_ASymbolic proj_regions aproj = + match aproj with + | AEndedProjBorrows _ | AIgnoredProjBorrows -> + (* We ignore borrows *) V.ASymbolic aproj + | AProjLoans _ -> + (* Loans are handled later *) + V.ASymbolic aproj + | AProjBorrows (sv, proj_ty) -> ( + (* Check if we need to reborrow *) + match reborrow_ashared (Option.get proj_regions) sv proj_ty with + | None -> super#visit_ASymbolic proj_regions aproj + | Some asb -> V.ABorrow (V.AProjSharedBorrow asb)) + | AEndedProjLoans _ -> + (* Sanity check: make sure there is nothing to expand inside the + * children projections *) + V.ASymbolic (self#visit_aproj proj_regions aproj) + end + in + (* Call the visitor *) + let ctx = obj#visit_eval_ctx None ctx in + (* Finally, replace the projectors on loans *) + let bids = !borrows in + assert (not (V.BorrowId.Set.is_empty bids)); + let see = V.SeSharedRef (bids, shared_sv) in + let allow_reborrows = true in + let ctx = + apply_symbolic_expansion_to_avalues config allow_reborrows original_sv see + ctx + in + (* Call the continuation *) + let expr = cf ctx in + (* Update the synthesized program *) + S.synthesize_symbolic_expansion_no_branching original_sv original_sv_place see + expr + +(** TODO: simplify and merge with the other expansion function *) +let expand_symbolic_value_borrow (config : C.config) + (original_sv : V.symbolic_value) (original_sv_place : SA.mplace option) + (region : T.RegionId.id T.region) (ref_ty : T.rty) (rkind : T.ref_kind) : + cm_fun = + fun cf ctx -> + (* Check that we are allowed to expand the reference *) + assert (not (region_in_set region ctx.ended_regions)); + (* Match on the reference kind *) + match rkind with + | T.Mut -> + (* Simple case: simply create a fresh symbolic value and a fresh + * borrow id *) + let sv = mk_fresh_symbolic_value original_sv.sv_kind ref_ty in + let bid = C.fresh_borrow_id () in + let see = V.SeMutRef (bid, sv) in + (* Expand the symbolic values - we simply perform a substitution (and + * check that we perform exactly one substitution) *) + let nv = symbolic_expansion_non_shared_borrow_to_value original_sv see in + let at_most_once = true in + let ctx = + replace_symbolic_values at_most_once original_sv nv.V.value ctx + in + (* Expand the symbolic avalues *) + let allow_reborrows = true in + let ctx = + apply_symbolic_expansion_to_avalues config allow_reborrows original_sv + see ctx + in + (* Apply the continuation *) + let expr = cf ctx in + (* Update the synthesized program *) + S.synthesize_symbolic_expansion_no_branching original_sv original_sv_place + see expr + | T.Shared -> + expand_symbolic_value_shared_borrow config original_sv original_sv_place + ref_ty cf ctx + +(** A small helper. + + Apply a branching symbolic expansion to a context and execute all the + branches. Note that the expansion is optional for every branch (this is + used for integer expansion: see [expand_symbolic_int]). + + [see_cf_l]: list of pairs (optional symbolic expansion, continuation) +*) +let apply_branching_symbolic_expansions_non_borrow (config : C.config) + (sv : V.symbolic_value) (sv_place : SA.mplace option) + (see_cf_l : (V.symbolic_expansion option * m_fun) list) : m_fun = + fun ctx -> + assert (see_cf_l <> []); + (* Apply the symbolic expansion in in the context and call the continuation *) + let resl = + List.map + (fun (see_opt, cf) -> + (* Expansion *) + let ctx = + match see_opt with + | None -> ctx + | Some see -> apply_symbolic_expansion_non_borrow config sv see ctx + in + (* Continuation *) + cf ctx) + see_cf_l + in + (* Collect the result: either we computed no subterm, or we computed all + * of them *) + let subterms = + match resl with + | Some _ :: _ -> Some (List.map Option.get resl) + | None :: _ -> + List.iter (fun res -> assert (res = None)) resl; + None + | _ -> raise (Failure "Unreachable") + in + (* Synthesize and return *) + let seel = List.map fst see_cf_l in + S.synthesize_symbolic_expansion sv sv_place seel subterms + +(** Expand a symbolic boolean *) +let expand_symbolic_bool (config : C.config) (sp : V.symbolic_value) + (sp_place : SA.mplace option) (cf_true : m_fun) (cf_false : m_fun) : m_fun = + fun ctx -> + (* Compute the expanded value *) + let original_sv = sp in + let original_sv_place = sp_place in + let rty = original_sv.V.sv_ty in + assert (rty = T.Bool); + (* Expand the symbolic value to true or false and continue execution *) + let see_true = V.SeConcrete (V.Bool true) in + let see_false = V.SeConcrete (V.Bool false) in + let seel = [ (Some see_true, cf_true); (Some see_false, cf_false) ] in + (* Apply the symbolic expansion (this also outputs the updated symbolic AST) *) + apply_branching_symbolic_expansions_non_borrow config original_sv + original_sv_place seel ctx + +(** Expand a symbolic value. + + [allow_branching]: if [true] we can branch (by expanding enumerations with + stricly more than one variant), otherwise we can't. + + TODO: rename [sp] to [sv] + *) +let expand_symbolic_value (config : C.config) (allow_branching : bool) + (sp : V.symbolic_value) (sp_place : SA.mplace option) : cm_fun = + fun cf ctx -> + (* Debug *) + log#ldebug (lazy ("expand_symbolic_value:" ^ symbolic_value_to_string ctx sp)); + (* Remember the initial context for printing purposes *) + let ctx0 = ctx in + (* Compute the expanded value - note that when doing so, we may introduce + * fresh symbolic values in the context (which thus gets updated) *) + let original_sv = sp in + let original_sv_place = sp_place in + let rty = original_sv.V.sv_ty in + let cc : cm_fun = + fun cf ctx -> + match rty with + (* TODO: I think it is possible to factorize a lot the below match *) + (* "Regular" ADTs *) + | T.Adt (T.AdtId def_id, regions, types) -> + (* Compute the expanded value *) + let seel = + compute_expanded_symbolic_adt_value allow_branching sp.sv_kind def_id + regions types ctx + in + (* Check for branching *) + assert (List.length seel <= 1 || allow_branching); + (* Apply *) + let seel = List.map (fun see -> (Some see, cf)) seel in + apply_branching_symbolic_expansions_non_borrow config original_sv + original_sv_place seel ctx + (* Options *) + | T.Adt (T.Assumed Option, regions, types) -> + (* Sanity check *) + assert (regions = []); + let ty = Collections.List.to_cons_nil types in + (* Compute the expanded value *) + let seel = + compute_expanded_symbolic_option_value allow_branching sp.sv_kind ty + in + + (* Check for branching *) + assert (List.length seel <= 1 || allow_branching); + (* Apply *) + let seel = List.map (fun see -> (Some see, cf)) seel in + apply_branching_symbolic_expansions_non_borrow config original_sv + original_sv_place seel ctx + (* Tuples *) + | T.Adt (T.Tuple, [], tys) -> + (* Generate the field values *) + let see = compute_expanded_symbolic_tuple_value sp.sv_kind tys in + (* Apply in the context *) + let ctx = + apply_symbolic_expansion_non_borrow config original_sv see ctx + in + (* Call the continuation *) + let expr = cf ctx in + (* Update the synthesized program *) + S.synthesize_symbolic_expansion_no_branching original_sv + original_sv_place see expr + (* Boxes *) + | T.Adt (T.Assumed T.Box, [], [ boxed_ty ]) -> + let see = compute_expanded_symbolic_box_value sp.sv_kind boxed_ty in + (* Apply in the context *) + let ctx = + apply_symbolic_expansion_non_borrow config original_sv see ctx + in + (* Call the continuation *) + let expr = cf ctx in + (* Update the synthesized program *) + S.synthesize_symbolic_expansion_no_branching original_sv + original_sv_place see expr + (* Borrows *) + | T.Ref (region, ref_ty, rkind) -> + expand_symbolic_value_borrow config original_sv original_sv_place region + ref_ty rkind cf ctx + (* Booleans *) + | T.Bool -> + assert allow_branching; + expand_symbolic_bool config sp sp_place cf cf ctx + | _ -> + raise + (Failure ("expand_symbolic_value: unexpected type: " ^ T.show_rty rty)) + in + (* Debug *) + let cc = + comp_unit cc (fun ctx -> + log#ldebug + (lazy + ("expand_symbolic_value: " + ^ symbolic_value_to_string ctx0 sp + ^ "\n\n- original context:\n" ^ eval_ctx_to_string ctx0 + ^ "\n\n- new context:\n" ^ eval_ctx_to_string ctx ^ "\n")); + (* Sanity check: the symbolic value has disappeared *) + assert (not (symbolic_value_id_in_ctx original_sv.V.sv_id ctx))) + in + (* Continue *) + cc cf ctx + +(** Symbolic integers are expanded upon evaluating a [switch], when the integer + is not an enumeration discriminant. + Note that a discriminant is never symbolic: we evaluate discriminant values + upon evaluating [eval_discriminant], which always generates a concrete value + (because if we call it on a symbolic enumeration, we expand the enumeration + *then* evaluate the discriminant). This is how we can spot "regular" switches + over integers. + + + When expanding a boolean upon evaluating an [if ... then ... else ...], + or an enumeration just before matching over it, we can simply expand the + boolean/enumeration (generating a list of contexts from which to execute) + then retry evaluating the [if ... then ... else ...] or the [match]: as + the scrutinee will then have a concrete value, the interpreter will switch + to the proper branch. + + However, when expanding a "regular" integer for a switch, there is always an + *otherwise* branch that we can take, for which the integer must remain symbolic + (because in this branch the scrutinee can take a range of values). We thus + can't simply expand then retry to evaluate the [switch], because then we + would loop... + + For this reason, we take the list of branches to execute as parameters, and + directly jump to those branches after the expansion, without reevaluating the + switch. The continuation is thus for the execution *after* the switch. +*) +let expand_symbolic_int (config : C.config) (sv : V.symbolic_value) + (sv_place : SA.mplace option) (int_type : T.integer_type) + (tgts : (V.scalar_value * m_fun) list) (otherwise : m_fun) : m_fun = + (* Sanity check *) + assert (sv.V.sv_ty = T.Integer int_type); + (* For all the branches of the switch, we expand the symbolic value + * to the value given by the branch and execute the branch statement. + * For the otherwise branch, we leave the symbolic value as it is + * (because this branch doesn't precisely define which should be the + * value of the scrutinee...) and simply execute the otherwise statement. + * + * First, generate the list of pairs: + * (optional expansion, statement to execute) + *) + let tgts = + List.map (fun (v, cf) -> (Some (V.SeConcrete (V.Scalar v)), cf)) tgts + in + let tgts = List.append tgts [ (None, otherwise) ] in + (* Then expand and evaluate - this generates the proper symbolic AST *) + apply_branching_symbolic_expansions_non_borrow config sv sv_place tgts + +(** See [expand_symbolic_value] *) +let expand_symbolic_value_no_branching (config : C.config) + (sv : V.symbolic_value) (sv_place : SA.mplace option) : cm_fun = + let allow_branching = false in + expand_symbolic_value config allow_branching sv sv_place + +(** Expand all the symbolic values which contain borrows. + Allows us to restrict ourselves to a simpler model for the projectors over + symbolic values. + + Fails if doing this requires to do a branching (because we need to expand + an enumeration with strictly more than one variant, a slice, etc.) or if + we need to expand a recursive type (because this leads to looping). + *) +let greedy_expand_symbolics_with_borrows (config : C.config) : cm_fun = + fun cf ctx -> + (* The visitor object, to look for symbolic values in the concrete environment *) + let obj = + object + inherit [_] C.iter_eval_ctx + + method! visit_Symbolic _ sv = + if ty_has_borrows ctx.type_context.type_infos sv.V.sv_ty then + raise (FoundSymbolicValue sv) + else () + + (** Don't enter abstractions *) + method! visit_abs _ _ = () + end + in + + let rec expand : cm_fun = + fun cf ctx -> + try + obj#visit_eval_ctx () ctx; + (* Nothing to expand: continue *) + cf ctx + with FoundSymbolicValue sv -> + (* Expand and recheck the environment *) + log#ldebug + (lazy + ("greedy_expand_symbolics_with_borrows: about to expand: " + ^ symbolic_value_to_string ctx sv)); + let cc : cm_fun = + match sv.V.sv_ty with + | T.Adt (AdtId def_id, _, _) -> + (* {!expand_symbolic_value_no_branching} checks if there are branchings, + * but we prefer to also check it here - this leads to cleaner messages + * and debugging *) + let def = C.ctx_lookup_type_decl ctx def_id in + (match def.kind with + | T.Struct _ | T.Enum ([] | [ _ ]) -> () + | T.Enum (_ :: _) -> + raise + (Failure + ("Attempted to greedily expand a symbolic enumeration \ + with > 1 variants (option \ + [greedy_expand_symbolics_with_borrows] of [config]): " + ^ Print.name_to_string def.name)) + | T.Opaque -> + raise (Failure "Attempted to greedily expand an opaque type")); + (* Also, we need to check if the definition is recursive *) + if C.ctx_type_decl_is_rec ctx def_id then + raise + (Failure + ("Attempted to greedily expand a recursive definition \ + (option [greedy_expand_symbolics_with_borrows] of \ + [config]): " + ^ Print.name_to_string def.name)) + else expand_symbolic_value_no_branching config sv None + | T.Adt ((Tuple | Assumed Box), _, _) | T.Ref (_, _, _) -> + (* Ok *) + expand_symbolic_value_no_branching config sv None + | T.Adt (Assumed (Vec | Option), _, _) -> + (* We can't expand those *) + raise (Failure "Attempted to greedily expand a Vec or an Option ") + | T.Array _ -> raise Errors.Unimplemented + | T.Slice _ -> raise (Failure "Can't expand symbolic slices") + | T.TypeVar _ | Bool | Char | Never | Integer _ | Str -> + raise (Failure "Unreachable") + in + (* Compose and continue *) + comp cc expand cf ctx + in + (* Apply *) + expand cf ctx + +(** If this mode is activated through the [config], greedily expand the symbolic + values which need to be expanded. See [config] for more information. + *) +let greedy_expand_symbolic_values (config : C.config) : cm_fun = + fun cf ctx -> + if config.greedy_expand_symbolics_with_borrows then ( + log#ldebug (lazy "greedy_expand_symbolic_values"); + greedy_expand_symbolics_with_borrows config cf ctx) + else cf ctx diff --git a/compiler/InterpreterExpressions.ml b/compiler/InterpreterExpressions.ml new file mode 100644 index 00000000..62d9b80b --- /dev/null +++ b/compiler/InterpreterExpressions.ml @@ -0,0 +1,720 @@ +module T = Types +module V = Values +module LA = LlbcAst +open Scalars +module E = Expressions +open Errors +module C = Contexts +module Subst = Substitute +module L = Logging +module PV = Print.Values +open TypesUtils +open ValuesUtils +module Inv = Invariants +module S = SynthesizeSymbolic +open Cps +open InterpreterUtils +open InterpreterExpansion +open InterpreterPaths + +(** The local logger *) +let log = L.expressions_log + +(** As long as there are symbolic values at a given place (potentially in subvalues) + which contain borrows and are primitively copyable, expand them. + + We use this function before copying values. + + Note that the place should have been prepared so that there are no remaining + loans. +*) +let expand_primitively_copyable_at_place (config : C.config) + (access : access_kind) (p : E.place) : cm_fun = + fun cf ctx -> + (* Small helper *) + let rec expand : cm_fun = + fun cf ctx -> + let v = read_place_unwrap config access p ctx in + match + find_first_primitively_copyable_sv_with_borrows + ctx.type_context.type_infos v + with + | None -> cf ctx + | Some sv -> + let cc = + expand_symbolic_value_no_branching config sv + (Some (S.mk_mplace p ctx)) + in + comp cc expand cf ctx + in + (* Apply *) + expand cf ctx + +(** Read a place (CPS-style function). + + We also check that the value *doesn't contain bottoms or inactivated + borrows. + *) +let read_place (config : C.config) (access : access_kind) (p : E.place) + (cf : V.typed_value -> m_fun) : m_fun = + fun ctx -> + let v = read_place_unwrap config access p ctx in + (* Check that there are no bottoms in the value *) + assert (not (bottom_in_value ctx.ended_regions v)); + (* Check that there are no inactivated borrows in the value *) + assert (not (inactivated_in_value v)); + (* Call the continuation *) + cf v ctx + +(** Small utility. + + Prepare the access to a place in a right-value (typically an operand) by + reorganizing the environment. + + We reorganize the environment so that: + - we can access the place (we prepare *along* the path) + - the value at the place itself doesn't contain loans (the [access_kind] + controls whether we only end mutable loans, or also shared loans). + + We also check, after the reorganization, that the value at the place + *doesn't contain any bottom nor inactivated borrows*. + + [expand_prim_copy]: if true, expand the symbolic values which are primitively + copyable and contain borrows. + *) +let access_rplace_reorganize_and_read (config : C.config) + (expand_prim_copy : bool) (access : access_kind) (p : E.place) + (cf : V.typed_value -> m_fun) : m_fun = + fun ctx -> + (* Make sure we can evaluate the path *) + let cc = update_ctx_along_read_place config access p in + (* End the proper loans at the place itself *) + let cc = comp cc (end_loans_at_place config access p) in + (* Expand the copyable values which contain borrows (which are necessarily shared + * borrows) *) + let cc = + if expand_prim_copy then + comp cc (expand_primitively_copyable_at_place config access p) + else cc + in + (* Read the place - note that this checks that the value doesn't contain bottoms *) + let read_place = read_place config access p in + (* Compose *) + comp cc read_place cf ctx + +let access_rplace_reorganize (config : C.config) (expand_prim_copy : bool) + (access : access_kind) (p : E.place) : cm_fun = + fun cf ctx -> + access_rplace_reorganize_and_read config expand_prim_copy access p + (fun _v -> cf) + ctx + +(** Convert an operand constant operand value to a typed value *) +let constant_to_typed_value (ty : T.ety) (cv : V.constant_value) : V.typed_value + = + (* Check the type while converting - we actually need some information + * contained in the type *) + log#ldebug + (lazy + ("constant_to_typed_value:" ^ "\n- cv: " ^ PV.constant_value_to_string cv)); + match (ty, cv) with + (* Scalar, boolean... *) + | T.Bool, Bool v -> { V.value = V.Concrete (Bool v); ty } + | T.Char, Char v -> { V.value = V.Concrete (Char v); ty } + | T.Str, String v -> { V.value = V.Concrete (String v); ty } + | T.Integer int_ty, V.Scalar v -> + (* Check the type and the ranges *) + assert (int_ty = v.int_ty); + assert (check_scalar_value_in_range v); + { V.value = V.Concrete (V.Scalar v); ty } + (* Remaining cases (invalid) *) + | _, _ -> failwith "Improperly typed constant value" + +(** Reorganize the environment in preparation for the evaluation of an operand. + + Evaluating an operand requires reorganizing the environment to get access + to a given place (by ending borrows, expanding symbolic values...) then + applying the operand operation (move, copy, etc.). + + Sometimes, we want to decouple the two operations. + Consider the following example: + {[ + context = { + x -> shared_borrow l0 + y -> shared_loan {l0} v + } + + dest <- f(move x, move y); + ... + ]} + Because of the way [end_borrow] is implemented, when giving back the borrow + [l0] upon evaluating [move y], we won't notice that [shared_borrow l0] has + disappeared from the environment (it has been moved and not assigned yet, + and so is hanging in "thin air"). + + By first "preparing" the operands evaluation, we make sure no such thing + happens. To be more precise, we make sure all the updates to borrows triggered + by access *and* move operations have already been applied. + + Rk.: in the formalization, we always have an explicit "reorganization" step + in the rule premises, before the actual operand evaluation. + + Rk.: doing this is actually not completely necessary because when + generating MIR, rustc introduces intermediate assignments for all the function + parameters. Still, it is better for soundness purposes, and corresponds to + what we do in the formalization (because we don't enforce constraints + in the formalization). + *) +let prepare_eval_operand_reorganize (config : C.config) (op : E.operand) : + cm_fun = + fun cf ctx -> + let prepare : cm_fun = + fun cf ctx -> + match op with + | Expressions.Constant (ty, cv) -> + (* No need to reorganize the context *) + constant_to_typed_value ty cv |> ignore; + cf ctx + | Expressions.Copy p -> + (* Access the value *) + let access = Read in + (* Expand the symbolic values, if necessary *) + let expand_prim_copy = true in + access_rplace_reorganize config expand_prim_copy access p cf ctx + | Expressions.Move p -> + (* Access the value *) + let access = Move in + let expand_prim_copy = false in + access_rplace_reorganize config expand_prim_copy access p cf ctx + in + (* Apply *) + prepare cf ctx + +(** Evaluate an operand, without reorganizing the context before *) +let eval_operand_no_reorganize (config : C.config) (op : E.operand) + (cf : V.typed_value -> m_fun) : m_fun = + fun ctx -> + (* Debug *) + log#ldebug + (lazy + ("eval_operand_no_reorganize: op: " ^ operand_to_string ctx op + ^ "\n- ctx:\n" ^ eval_ctx_to_string ctx ^ "\n")); + (* Evaluate *) + match op with + | Expressions.Constant (ty, cv) -> cf (constant_to_typed_value ty cv) ctx + | Expressions.Copy p -> + (* Access the value *) + let access = Read in + let cc = read_place config access p in + (* Copy the value *) + let copy cf v : m_fun = + fun ctx -> + (* Sanity checks *) + assert (not (bottom_in_value ctx.ended_regions v)); + assert ( + Option.is_none + (find_first_primitively_copyable_sv_with_borrows + ctx.type_context.type_infos v)); + (* Actually perform the copy *) + let allow_adt_copy = false in + let ctx, v = copy_value allow_adt_copy config ctx v in + (* Continue *) + cf v ctx + in + (* Compose and apply *) + comp cc copy cf ctx + | Expressions.Move p -> + (* Access the value *) + let access = Move in + let cc = read_place config access p in + (* Move the value *) + let move cf v : m_fun = + fun ctx -> + (* Check that there are no bottoms in the value we are about to move *) + assert (not (bottom_in_value ctx.ended_regions v)); + let bottom : V.typed_value = { V.value = Bottom; ty = v.ty } in + match write_place config access p bottom ctx with + | Error _ -> failwith "Unreachable" + | Ok ctx -> cf v ctx + in + (* Compose and apply *) + comp cc move cf ctx + +(** Evaluate an operand. + + Reorganize the context, then evaluate the operand. + + **Warning**: this function shouldn't be used to evaluate a list of + operands (for a function call, for instance): we must do *one* reorganization + of the environment, before evaluating all the operands at once. + Use [eval_operands] instead. + *) +let eval_operand (config : C.config) (op : E.operand) + (cf : V.typed_value -> m_fun) : m_fun = + fun ctx -> + (* Debug *) + log#ldebug + (lazy + ("eval_operand: op: " ^ operand_to_string ctx op ^ "\n- ctx:\n" + ^ eval_ctx_to_string ctx ^ "\n")); + (* We reorganize the context, then evaluate the operand *) + comp + (prepare_eval_operand_reorganize config op) + (eval_operand_no_reorganize config op) + cf ctx + +(** Small utility. + + See [prepare_eval_operand_reorganize]. + *) +let prepare_eval_operands_reorganize (config : C.config) (ops : E.operand list) + : cm_fun = + fold_left_apply_continuation (prepare_eval_operand_reorganize config) ops + +(** Evaluate several operands. *) +let eval_operands (config : C.config) (ops : E.operand list) + (cf : V.typed_value list -> m_fun) : m_fun = + fun ctx -> + (* Prepare the operands *) + let prepare = prepare_eval_operands_reorganize config ops in + (* Evaluate the operands *) + let eval = + fold_left_list_apply_continuation (eval_operand_no_reorganize config) ops + in + (* Compose and apply *) + comp prepare eval cf ctx + +let eval_two_operands (config : C.config) (op1 : E.operand) (op2 : E.operand) + (cf : V.typed_value * V.typed_value -> m_fun) : m_fun = + let eval_op = eval_operands config [ op1; op2 ] in + let use_res cf res = + match res with [ v1; v2 ] -> cf (v1, v2) | _ -> failwith "Unreachable" + in + comp eval_op use_res cf + +let eval_unary_op_concrete (config : C.config) (unop : E.unop) (op : E.operand) + (cf : (V.typed_value, eval_error) result -> m_fun) : m_fun = + (* Evaluate the operand *) + let eval_op = eval_operand config op in + (* Apply the unop *) + let apply cf (v : V.typed_value) : m_fun = + match (unop, v.V.value) with + | E.Not, V.Concrete (Bool b) -> + cf (Ok { v with V.value = V.Concrete (Bool (not b)) }) + | E.Neg, V.Concrete (V.Scalar sv) -> ( + let i = Z.neg sv.V.value in + match mk_scalar sv.int_ty i with + | Error _ -> cf (Error EPanic) + | Ok sv -> cf (Ok { v with V.value = V.Concrete (V.Scalar sv) })) + | E.Cast (src_ty, tgt_ty), V.Concrete (V.Scalar sv) -> ( + assert (src_ty == sv.int_ty); + let i = sv.V.value in + match mk_scalar tgt_ty i with + | Error _ -> cf (Error EPanic) + | Ok sv -> + let ty = T.Integer tgt_ty in + let value = V.Concrete (V.Scalar sv) in + cf (Ok { V.ty; value })) + | _ -> raise (Failure "Invalid input for unop") + in + comp eval_op apply cf + +let eval_unary_op_symbolic (config : C.config) (unop : E.unop) (op : E.operand) + (cf : (V.typed_value, eval_error) result -> m_fun) : m_fun = + fun ctx -> + (* Evaluate the operand *) + let eval_op = eval_operand config op in + (* Generate a fresh symbolic value to store the result *) + let apply cf (v : V.typed_value) : m_fun = + fun ctx -> + let res_sv_id = C.fresh_symbolic_value_id () in + let res_sv_ty = + match (unop, v.V.ty) with + | E.Not, T.Bool -> T.Bool + | E.Neg, T.Integer int_ty -> T.Integer int_ty + | E.Cast (_, tgt_ty), _ -> T.Integer tgt_ty + | _ -> raise (Failure "Invalid input for unop") + in + let res_sv = + { V.sv_kind = V.FunCallRet; V.sv_id = res_sv_id; sv_ty = res_sv_ty } + in + (* Call the continuation *) + let expr = cf (Ok (mk_typed_value_from_symbolic_value res_sv)) ctx in + (* Synthesize the symbolic AST *) + S.synthesize_unary_op unop v + (S.mk_opt_place_from_op op ctx) + res_sv None expr + in + (* Compose and apply *) + comp eval_op apply cf ctx + +let eval_unary_op (config : C.config) (unop : E.unop) (op : E.operand) + (cf : (V.typed_value, eval_error) result -> m_fun) : m_fun = + match config.mode with + | C.ConcreteMode -> eval_unary_op_concrete config unop op cf + | C.SymbolicMode -> eval_unary_op_symbolic config unop op cf + +(** Small helper for [eval_binary_op_concrete]: computes the result of applying + the binop *after* the operands have been successfully evaluated + *) +let eval_binary_op_concrete_compute (binop : E.binop) (v1 : V.typed_value) + (v2 : V.typed_value) : (V.typed_value, eval_error) result = + (* Equality check binops (Eq, Ne) accept values from a wide variety of types. + * The remaining binops only operate on scalars. *) + if binop = Eq || binop = Ne then ( + (* Equality operations *) + assert (v1.ty = v2.ty); + (* Equality/inequality check is primitive only for a subset of types *) + assert (ty_is_primitively_copyable v1.ty); + let b = v1 = v2 in + Ok { V.value = V.Concrete (Bool b); ty = T.Bool }) + else + (* For the non-equality operations, the input values are necessarily scalars *) + match (v1.V.value, v2.V.value) with + | V.Concrete (V.Scalar sv1), V.Concrete (V.Scalar sv2) -> ( + (* There are binops which require the two operands to have the same + type, and binops for which it is not the case. + There are also binops which return booleans, and binops which + return integers. + *) + match binop with + | E.Lt | E.Le | E.Ge | E.Gt -> + (* The two operands must have the same type and the result is a boolean *) + assert (sv1.int_ty = sv2.int_ty); + let b = + match binop with + | E.Lt -> Z.lt sv1.V.value sv2.V.value + | E.Le -> Z.leq sv1.V.value sv2.V.value + | E.Ge -> Z.geq sv1.V.value sv2.V.value + | E.Gt -> Z.gt sv1.V.value sv2.V.value + | E.Div | E.Rem | E.Add | E.Sub | E.Mul | E.BitXor | E.BitAnd + | E.BitOr | E.Shl | E.Shr | E.Ne | E.Eq -> + raise (Failure "Unreachable") + in + Ok ({ V.value = V.Concrete (Bool b); ty = T.Bool } : V.typed_value) + | E.Div | E.Rem | E.Add | E.Sub | E.Mul | E.BitXor | E.BitAnd | E.BitOr + -> ( + (* The two operands must have the same type and the result is an integer *) + assert (sv1.int_ty = sv2.int_ty); + let res = + match binop with + | E.Div -> + if sv2.V.value = Z.zero then Error () + else mk_scalar sv1.int_ty (Z.div sv1.V.value sv2.V.value) + | E.Rem -> + (* See [https://github.com/ocaml/Zarith/blob/master/z.mli] *) + if sv2.V.value = Z.zero then Error () + else mk_scalar sv1.int_ty (Z.rem sv1.V.value sv2.V.value) + | E.Add -> mk_scalar sv1.int_ty (Z.add sv1.V.value sv2.V.value) + | E.Sub -> mk_scalar sv1.int_ty (Z.sub sv1.V.value sv2.V.value) + | E.Mul -> mk_scalar sv1.int_ty (Z.mul sv1.V.value sv2.V.value) + | E.BitXor -> raise Unimplemented + | E.BitAnd -> raise Unimplemented + | E.BitOr -> raise Unimplemented + | E.Lt | E.Le | E.Ge | E.Gt | E.Shl | E.Shr | E.Ne | E.Eq -> + raise (Failure "Unreachable") + in + match res with + | Error _ -> Error EPanic + | Ok sv -> + Ok + { + V.value = V.Concrete (V.Scalar sv); + ty = Integer sv1.int_ty; + }) + | E.Shl | E.Shr -> raise Unimplemented + | E.Ne | E.Eq -> raise (Failure "Unreachable")) + | _ -> raise (Failure "Invalid inputs for binop") + +let eval_binary_op_concrete (config : C.config) (binop : E.binop) + (op1 : E.operand) (op2 : E.operand) + (cf : (V.typed_value, eval_error) result -> m_fun) : m_fun = + (* Evaluate the operands *) + let eval_ops = eval_two_operands config op1 op2 in + (* Compute the result of the binop *) + let compute cf (res : V.typed_value * V.typed_value) = + let v1, v2 = res in + cf (eval_binary_op_concrete_compute binop v1 v2) + in + (* Compose and apply *) + comp eval_ops compute cf + +let eval_binary_op_symbolic (config : C.config) (binop : E.binop) + (op1 : E.operand) (op2 : E.operand) + (cf : (V.typed_value, eval_error) result -> m_fun) : m_fun = + fun ctx -> + (* Evaluate the operands *) + let eval_ops = eval_two_operands config op1 op2 in + (* Compute the result of applying the binop *) + let compute cf ((v1, v2) : V.typed_value * V.typed_value) : m_fun = + fun ctx -> + (* Generate a fresh symbolic value to store the result *) + let res_sv_id = C.fresh_symbolic_value_id () in + let res_sv_ty = + if binop = Eq || binop = Ne then ( + (* Equality operations *) + assert (v1.ty = v2.ty); + (* Equality/inequality check is primitive only for a subset of types *) + assert (ty_is_primitively_copyable v1.ty); + T.Bool) + else + (* Other operations: input types are integers *) + match (v1.V.ty, v2.V.ty) with + | T.Integer int_ty1, T.Integer int_ty2 -> ( + match binop with + | E.Lt | E.Le | E.Ge | E.Gt -> + assert (int_ty1 = int_ty2); + T.Bool + | E.Div | E.Rem | E.Add | E.Sub | E.Mul | E.BitXor | E.BitAnd + | E.BitOr -> + assert (int_ty1 = int_ty2); + T.Integer int_ty1 + | E.Shl | E.Shr -> raise Unimplemented + | E.Ne | E.Eq -> raise (Failure "Unreachable")) + | _ -> raise (Failure "Invalid inputs for binop") + in + let res_sv = + { V.sv_kind = V.FunCallRet; V.sv_id = res_sv_id; sv_ty = res_sv_ty } + in + (* Call the continuattion *) + let v = mk_typed_value_from_symbolic_value res_sv in + let expr = cf (Ok v) ctx in + (* Synthesize the symbolic AST *) + let p1 = S.mk_opt_place_from_op op1 ctx in + let p2 = S.mk_opt_place_from_op op2 ctx in + S.synthesize_binary_op binop v1 p1 v2 p2 res_sv None expr + in + (* Compose and apply *) + comp eval_ops compute cf ctx + +let eval_binary_op (config : C.config) (binop : E.binop) (op1 : E.operand) + (op2 : E.operand) (cf : (V.typed_value, eval_error) result -> m_fun) : m_fun + = + match config.mode with + | C.ConcreteMode -> eval_binary_op_concrete config binop op1 op2 cf + | C.SymbolicMode -> eval_binary_op_symbolic config binop op1 op2 cf + +(** Evaluate the discriminant of a concrete (i.e., non symbolic) ADT value *) +let eval_rvalue_discriminant_concrete (config : C.config) (p : E.place) + (cf : V.typed_value -> m_fun) : m_fun = + (* Note that discriminant values have type [isize] *) + (* Access the value *) + let access = Read in + let expand_prim_copy = false in + let prepare = + access_rplace_reorganize_and_read config expand_prim_copy access p + in + (* Read the value *) + let read (cf : V.typed_value -> m_fun) (v : V.typed_value) : m_fun = + (* The value may be shared: we need to ignore the shared loans *) + let v = value_strip_shared_loans v in + match v.V.value with + | Adt av -> ( + match av.variant_id with + | None -> + raise + (Failure + "Invalid input for `discriminant`: structure instead of enum") + | Some variant_id -> ( + let id = Z.of_int (T.VariantId.to_int variant_id) in + match mk_scalar Isize id with + | Error _ -> raise (Failure "Disciminant id out of range") + (* Should really never happen *) + | Ok sv -> + cf { V.value = V.Concrete (V.Scalar sv); ty = Integer Isize })) + | _ -> + raise + (Failure ("Invalid input for `discriminant`: " ^ V.show_typed_value v)) + in + (* Compose and apply *) + comp prepare read cf + +(** Evaluate the discriminant of an ADT value. + + Might lead to branching, if the value is symbolic. + *) +let eval_rvalue_discriminant (config : C.config) (p : E.place) + (cf : V.typed_value -> m_fun) : m_fun = + fun ctx -> + log#ldebug (lazy "eval_rvalue_discriminant"); + (* Note that discriminant values have type [isize] *) + (* Access the value *) + let access = Read in + let expand_prim_copy = false in + let prepare = + access_rplace_reorganize_and_read config expand_prim_copy access p + in + (* Read the value *) + let read (cf : V.typed_value -> m_fun) (v : V.typed_value) : m_fun = + fun ctx -> + (* The value may be shared: we need to ignore the shared loans *) + let v = value_strip_shared_loans v in + match v.V.value with + | Adt _ -> eval_rvalue_discriminant_concrete config p cf ctx + | Symbolic sv -> + (* Expand the symbolic value - may lead to branching *) + let allow_branching = true in + let cc = + expand_symbolic_value config allow_branching sv + (Some (S.mk_mplace p ctx)) + in + (* This time the value is concrete: reevaluate *) + comp cc (eval_rvalue_discriminant_concrete config p) cf ctx + | _ -> + raise + (Failure ("Invalid input for `discriminant`: " ^ V.show_typed_value v)) + in + (* Compose and apply *) + comp prepare read cf ctx + +let eval_rvalue_ref (config : C.config) (p : E.place) (bkind : E.borrow_kind) + (cf : V.typed_value -> m_fun) : m_fun = + fun ctx -> + match bkind with + | E.Shared | E.TwoPhaseMut -> + (* Access the value *) + let access = if bkind = E.Shared then Read else Write in + let expand_prim_copy = false in + let prepare = + access_rplace_reorganize_and_read config expand_prim_copy access p + in + (* Evaluate the borrowing operation *) + let eval (cf : V.typed_value -> m_fun) (v : V.typed_value) : m_fun = + fun ctx -> + (* Generate the fresh borrow id *) + let bid = C.fresh_borrow_id () in + (* Compute the loan value, with which to replace the value at place p *) + let nv, shared_mvalue = + match v.V.value with + | V.Loan (V.SharedLoan (bids, sv)) -> + (* Shared loan: insert the new borrow id *) + let bids1 = V.BorrowId.Set.add bid bids in + ({ v with V.value = V.Loan (V.SharedLoan (bids1, sv)) }, sv) + | _ -> + (* Not a shared loan: add a wrapper *) + let v' = + V.Loan (V.SharedLoan (V.BorrowId.Set.singleton bid, v)) + in + ({ v with V.value = v' }, v) + in + (* Update the borrowed value in the context *) + let ctx = write_place_unwrap config access p nv ctx in + (* Compute the rvalue - simply a shared borrow with a the fresh id. + * Note that the reference is *mutable* if we do a two-phase borrow *) + let rv_ty = + T.Ref (T.Erased, v.ty, if bkind = E.Shared then Shared else Mut) + in + let bc = + if bkind = E.Shared then V.SharedBorrow (shared_mvalue, bid) + else V.InactivatedMutBorrow (shared_mvalue, bid) + in + let rv : V.typed_value = { V.value = V.Borrow bc; ty = rv_ty } in + (* Continue *) + cf rv ctx + in + (* Compose and apply *) + comp prepare eval cf ctx + | E.Mut -> + (* Access the value *) + let access = Write in + let expand_prim_copy = false in + let prepare = + access_rplace_reorganize_and_read config expand_prim_copy access p + in + (* Evaluate the borrowing operation *) + let eval (cf : V.typed_value -> m_fun) (v : V.typed_value) : m_fun = + fun ctx -> + (* Compute the rvalue - wrap the value in a mutable borrow with a fresh id *) + let bid = C.fresh_borrow_id () in + let rv_ty = T.Ref (T.Erased, v.ty, Mut) in + let rv : V.typed_value = + { V.value = V.Borrow (V.MutBorrow (bid, v)); ty = rv_ty } + in + (* Compute the value with which to replace the value at place p *) + let nv = { v with V.value = V.Loan (V.MutLoan bid) } in + (* Update the value in the context *) + let ctx = write_place_unwrap config access p nv ctx in + (* Continue *) + cf rv ctx + in + (* Compose and apply *) + comp prepare eval cf ctx + +let eval_rvalue_aggregate (config : C.config) + (aggregate_kind : E.aggregate_kind) (ops : E.operand list) + (cf : V.typed_value -> m_fun) : m_fun = + (* Evaluate the operands *) + let eval_ops = eval_operands config ops in + (* Compute the value *) + let compute (cf : V.typed_value -> m_fun) (values : V.typed_value list) : + m_fun = + fun ctx -> + (* Match on the aggregate kind *) + match aggregate_kind with + | E.AggregatedTuple -> + let tys = List.map (fun (v : V.typed_value) -> v.V.ty) values in + let v = V.Adt { variant_id = None; field_values = values } in + let ty = T.Adt (T.Tuple, [], tys) in + let aggregated : V.typed_value = { V.value = v; ty } in + (* Call the continuation *) + cf aggregated ctx + | E.AggregatedOption (variant_id, ty) -> + (* Sanity check *) + if variant_id == T.option_none_id then assert (values == []) + else if variant_id == T.option_some_id then + assert (List.length values == 1) + else raise (Failure "Unreachable"); + (* Construt the value *) + let aty = T.Adt (T.Assumed T.Option, [], [ ty ]) in + let av : V.adt_value = + { V.variant_id = Some variant_id; V.field_values = values } + in + let aggregated : V.typed_value = { V.value = Adt av; ty = aty } in + (* Call the continuation *) + cf aggregated ctx + | E.AggregatedAdt (def_id, opt_variant_id, regions, types) -> + (* Sanity checks *) + let type_decl = C.ctx_lookup_type_decl ctx def_id in + assert (List.length type_decl.region_params = List.length regions); + let expected_field_types = + Subst.ctx_adt_get_instantiated_field_etypes ctx def_id opt_variant_id + types + in + assert ( + expected_field_types + = List.map (fun (v : V.typed_value) -> v.V.ty) values); + (* Construct the value *) + let av : V.adt_value = + { V.variant_id = opt_variant_id; V.field_values = values } + in + let aty = T.Adt (T.AdtId def_id, regions, types) in + let aggregated : V.typed_value = { V.value = Adt av; ty = aty } in + (* Call the continuation *) + cf aggregated ctx + in + (* Compose and apply *) + comp eval_ops compute cf + +(** Evaluate an rvalue. + + Transmits the computed rvalue to the received continuation. + *) +let eval_rvalue (config : C.config) (rvalue : E.rvalue) + (cf : (V.typed_value, eval_error) result -> m_fun) : m_fun = + fun ctx -> + log#ldebug (lazy "eval_rvalue"); + (* Small helpers *) + let wrap_in_result (cf : (V.typed_value, eval_error) result -> m_fun) + (v : V.typed_value) : m_fun = + cf (Ok v) + in + let comp_wrap f = comp f wrap_in_result cf in + (* Delegate to the proper auxiliary function *) + match rvalue with + | E.Use op -> comp_wrap (eval_operand config op) ctx + | E.Ref (p, bkind) -> comp_wrap (eval_rvalue_ref config p bkind) ctx + | E.UnaryOp (unop, op) -> eval_unary_op config unop op cf ctx + | E.BinaryOp (binop, op1, op2) -> eval_binary_op config binop op1 op2 cf ctx + | E.Aggregate (aggregate_kind, ops) -> + comp_wrap (eval_rvalue_aggregate config aggregate_kind ops) ctx + | E.Discriminant p -> comp_wrap (eval_rvalue_discriminant config p) ctx diff --git a/compiler/InterpreterPaths.ml b/compiler/InterpreterPaths.ml new file mode 100644 index 00000000..d54a046e --- /dev/null +++ b/compiler/InterpreterPaths.ml @@ -0,0 +1,801 @@ +module T = Types +module V = Values +module E = Expressions +module C = Contexts +module Subst = Substitute +module L = Logging +open Cps +open TypesUtils +open ValuesUtils +open InterpreterUtils +open InterpreterBorrowsCore +open InterpreterBorrows +open InterpreterExpansion +module Synth = SynthesizeSymbolic + +(** The local logger *) +let log = L.paths_log + +(** Paths *) + +(** When we fail reading from or writing to a path, it might be because we + need to update the environment by ending borrows, expanding symbolic + values, etc. The following type is used to convey this information. + + TODO: compare with borrow_lres? +*) +type path_fail_kind = + | FailSharedLoan of V.BorrowId.Set.t + (** Failure because we couldn't go inside a shared loan *) + | FailMutLoan of V.BorrowId.id + (** Failure because we couldn't go inside a mutable loan *) + | FailInactivatedMutBorrow of V.BorrowId.id + (** Failure because we couldn't go inside an inactivated mutable borrow + (which should get activated) *) + | FailSymbolic of int * V.symbolic_value + (** Failure because we need to enter a symbolic value (and thus need to + expand it). + We return the number of elements which remained in the path when we + reached the error - this allows to retrieve the path prefix, which + is useful for the synthesis. *) + | FailBottom of int * E.projection_elem * T.ety + (** Failure because we need to enter an any value - we can expand Bottom + values if they are left values. We return the number of elements which + remained in the path when we reached the error - this allows to + properly update the Bottom value, if needs be. + *) + | FailBorrow of V.borrow_content + (** We got stuck because we couldn't enter a borrow *) + +(** Result of evaluating a path (reading from a path/writing to a path) + + Note that when we fail, we return information used to update the + environment, as well as the +*) +type 'a path_access_result = ('a, path_fail_kind) result +(** The result of reading from/writing to a place *) + +type updated_read_value = { read : V.typed_value; updated : V.typed_value } + +type projection_access = { + enter_shared_loans : bool; + enter_mut_borrows : bool; + lookup_shared_borrows : bool; +} + +(** Generic function to access (read/write) the value at the end of a projection. + + We return the (eventually) updated value, the value we read at the end of + the place and the (eventually) updated environment. + + TODO: use exceptions? + *) +let rec access_projection (access : projection_access) (ctx : C.eval_ctx) + (* Function to (eventually) update the value we find *) + (update : V.typed_value -> V.typed_value) (p : E.projection) + (v : V.typed_value) : (C.eval_ctx * updated_read_value) path_access_result = + (* For looking up/updating shared loans *) + let ek : exploration_kind = + { enter_shared_loans = true; enter_mut_borrows = true; enter_abs = true } + in + match p with + | [] -> + let nv = update v in + (* Type checking *) + if nv.ty <> v.ty then ( + log#lerror + (lazy + ("Not the same type:\n- nv.ty: " ^ T.show_ety nv.ty ^ "\n- v.ty: " + ^ T.show_ety v.ty)); + failwith + "Assertion failed: new value doesn't have the same type as its \ + destination"); + Ok (ctx, { read = v; updated = nv }) + | pe :: p' -> ( + (* Match on the projection element and the value *) + match (pe, v.V.value, v.V.ty) with + | ( Field (((ProjAdt (_, _) | ProjOption _) as proj_kind), field_id), + V.Adt adt, + T.Adt (type_id, _, _) ) -> ( + (* Check consistency *) + (match (proj_kind, type_id) with + | ProjAdt (def_id, opt_variant_id), T.AdtId def_id' -> + assert (def_id = def_id'); + assert (opt_variant_id = adt.variant_id) + | ProjOption variant_id, T.Assumed T.Option -> + assert (Some variant_id = adt.variant_id) + | _ -> failwith "Unreachable"); + (* Actually project *) + let fv = T.FieldId.nth adt.field_values field_id in + match access_projection access ctx update p' fv with + | Error err -> Error err + | Ok (ctx, res) -> + (* Update the field value *) + let nvalues = + T.FieldId.update_nth adt.field_values field_id res.updated + in + let nadt = V.Adt { adt with V.field_values = nvalues } in + let updated = { v with value = nadt } in + Ok (ctx, { res with updated })) + (* Tuples *) + | Field (ProjTuple arity, field_id), V.Adt adt, T.Adt (T.Tuple, _, _) -> ( + assert (arity = List.length adt.field_values); + let fv = T.FieldId.nth adt.field_values field_id in + (* Project *) + match access_projection access ctx update p' fv with + | Error err -> Error err + | Ok (ctx, res) -> + (* Update the field value *) + let nvalues = + T.FieldId.update_nth adt.field_values field_id res.updated + in + let ntuple = V.Adt { adt with field_values = nvalues } in + let updated = { v with value = ntuple } in + Ok (ctx, { res with updated }) + (* If we reach Bottom, it may mean we need to expand an uninitialized + * enumeration value *)) + | Field ((ProjAdt (_, _) | ProjTuple _ | ProjOption _), _), V.Bottom, _ -> + Error (FailBottom (1 + List.length p', pe, v.ty)) + (* Symbolic value: needs to be expanded *) + | _, Symbolic sp, _ -> + (* Expand the symbolic value *) + Error (FailSymbolic (1 + List.length p', sp)) + (* Box dereferencement *) + | ( DerefBox, + Adt { variant_id = None; field_values = [ bv ] }, + T.Adt (T.Assumed T.Box, _, _) ) -> ( + (* We allow moving inside of boxes. In practice, this kind of + * manipulations should happen only inside unsage code, so + * it shouldn't happen due to user code, and we leverage it + * when implementing box dereferencement for the concrete + * interpreter *) + match access_projection access ctx update p' bv with + | Error err -> Error err + | Ok (ctx, res) -> + let nv = + { + v with + value = + V.Adt { variant_id = None; field_values = [ res.updated ] }; + } + in + Ok (ctx, { res with updated = nv })) + (* Borrows *) + | Deref, V.Borrow bc, _ -> ( + match bc with + | V.SharedBorrow (_, bid) -> + (* Lookup the loan content, and explore from there *) + if access.lookup_shared_borrows then + match lookup_loan ek bid ctx with + | _, Concrete (V.MutLoan _) -> failwith "Expected a shared loan" + | _, Concrete (V.SharedLoan (bids, sv)) -> ( + (* Explore the shared value *) + match access_projection access ctx update p' sv with + | Error err -> Error err + | Ok (ctx, res) -> + (* Update the shared loan with the new value returned + by {!access_projection} *) + let ctx = + update_loan ek bid + (V.SharedLoan (bids, res.updated)) + ctx + in + (* Return - note that we don't need to update the borrow itself *) + Ok (ctx, { res with updated = v })) + | ( _, + Abstract + ( V.AMutLoan (_, _) + | V.AEndedMutLoan + { given_back = _; child = _; given_back_meta = _ } + | V.AEndedSharedLoan (_, _) + | V.AIgnoredMutLoan (_, _) + | V.AEndedIgnoredMutLoan + { given_back = _; child = _; given_back_meta = _ } + | V.AIgnoredSharedLoan _ ) ) -> + failwith "Expected a shared (abstraction) loan" + | _, Abstract (V.ASharedLoan (bids, sv, _av)) -> ( + (* Explore the shared value *) + match access_projection access ctx update p' sv with + | Error err -> Error err + | Ok (ctx, res) -> + (* Relookup the child avalue *) + let av = + match lookup_loan ek bid ctx with + | _, Abstract (V.ASharedLoan (_, _, av)) -> av + | _ -> failwith "Unexpected" + in + (* Update the shared loan with the new value returned + by {!access_projection} *) + let ctx = + update_aloan ek bid + (V.ASharedLoan (bids, res.updated, av)) + ctx + in + (* Return - note that we don't need to update the borrow itself *) + Ok (ctx, { res with updated = v })) + else Error (FailBorrow bc) + | V.InactivatedMutBorrow (_, bid) -> + Error (FailInactivatedMutBorrow bid) + | V.MutBorrow (bid, bv) -> + if access.enter_mut_borrows then + match access_projection access ctx update p' bv with + | Error err -> Error err + | Ok (ctx, res) -> + let nv = + { + v with + value = V.Borrow (V.MutBorrow (bid, res.updated)); + } + in + Ok (ctx, { res with updated = nv }) + else Error (FailBorrow bc)) + | _, V.Loan lc, _ -> ( + match lc with + | V.MutLoan bid -> Error (FailMutLoan bid) + | V.SharedLoan (bids, sv) -> + (* If we can enter shared loan, we ignore the loan. Pay attention + to the fact that we need to reexplore the *whole* place (i.e, + we mustn't ignore the current projection element *) + if access.enter_shared_loans then + match access_projection access ctx update (pe :: p') sv with + | Error err -> Error err + | Ok (ctx, res) -> + let nv = + { + v with + value = V.Loan (V.SharedLoan (bids, res.updated)); + } + in + Ok (ctx, { res with updated = nv }) + else Error (FailSharedLoan bids)) + | (_, (V.Concrete _ | V.Adt _ | V.Bottom | V.Borrow _), _) as r -> + let pe, v, ty = r in + let pe = "- pe: " ^ E.show_projection_elem pe in + let v = "- v:\n" ^ V.show_value v in + let ty = "- ty:\n" ^ T.show_ety ty in + log#serror ("Inconsistent projection:\n" ^ pe ^ "\n" ^ v ^ "\n" ^ ty); + failwith "Inconsistent projection") + +(** Generic function to access (read/write) the value at a given place. + + We return the value we read at the place and the (eventually) updated + environment, if we managed to access the place, or the precise reason + why we failed. + *) +let access_place (access : projection_access) + (* Function to (eventually) update the value we find *) + (update : V.typed_value -> V.typed_value) (p : E.place) (ctx : C.eval_ctx) + : (C.eval_ctx * V.typed_value) path_access_result = + (* Lookup the variable's value *) + let value = C.ctx_lookup_var_value ctx p.var_id in + (* Apply the projection *) + match access_projection access ctx update p.projection value with + | Error err -> Error err + | Ok (ctx, res) -> + (* Update the value *) + let ctx = C.ctx_update_var_value ctx p.var_id res.updated in + (* Return *) + Ok (ctx, res.read) + +type access_kind = + | Read (** We can go inside borrows and loans *) + | Write (** Don't enter shared borrows or shared loans *) + | Move (** Don't enter borrows or loans *) + +let access_kind_to_projection_access (access : access_kind) : projection_access + = + match access with + | Read -> + { + enter_shared_loans = true; + enter_mut_borrows = true; + lookup_shared_borrows = true; + } + | Write -> + { + enter_shared_loans = false; + enter_mut_borrows = true; + lookup_shared_borrows = false; + } + | Move -> + { + enter_shared_loans = false; + enter_mut_borrows = false; + lookup_shared_borrows = false; + } + +(** Read the value at a given place. + + Note that we only access the value at the place, and do not check that + the value is "well-formed" (for instance that it doesn't contain bottoms). + *) +let read_place (config : C.config) (access : access_kind) (p : E.place) + (ctx : C.eval_ctx) : V.typed_value path_access_result = + let access = access_kind_to_projection_access access in + (* The update function is the identity *) + let update v = v in + match access_place access update p ctx with + | Error err -> Error err + | Ok (ctx1, read_value) -> + (* Note that we ignore the new environment: it should be the same as the + original one. + *) + if config.check_invariants then + if ctx1 <> ctx then ( + let msg = + "Unexpected environment update:\nNew environment:\n" + ^ C.show_env ctx1.env ^ "\n\nOld environment:\n" + ^ C.show_env ctx.env + in + log#serror msg; + failwith "Unexpected environment update"); + Ok read_value + +let read_place_unwrap (config : C.config) (access : access_kind) (p : E.place) + (ctx : C.eval_ctx) : V.typed_value = + match read_place config access p ctx with + | Error _ -> failwith "Unreachable" + | Ok v -> v + +(** Update the value at a given place *) +let write_place (_config : C.config) (access : access_kind) (p : E.place) + (nv : V.typed_value) (ctx : C.eval_ctx) : C.eval_ctx path_access_result = + let access = access_kind_to_projection_access access in + (* The update function substitutes the value with the new value *) + let update _ = nv in + match access_place access update p ctx with + | Error err -> Error err + | Ok (ctx, _) -> + (* We ignore the read value *) + Ok ctx + +let write_place_unwrap (config : C.config) (access : access_kind) (p : E.place) + (nv : V.typed_value) (ctx : C.eval_ctx) : C.eval_ctx = + match write_place config access p nv ctx with + | Error _ -> failwith "Unreachable" + | Ok ctx -> ctx + +(** Compute an expanded ADT bottom value *) +let compute_expanded_bottom_adt_value (tyctx : T.type_decl T.TypeDeclId.Map.t) + (def_id : T.TypeDeclId.id) (opt_variant_id : T.VariantId.id option) + (regions : T.erased_region list) (types : T.ety list) : V.typed_value = + (* Lookup the definition and check if it is an enumeration - it + should be an enumeration if and only if the projection element + is a field projection with *some* variant id. Retrieve the list + of fields at the same time. *) + let def = T.TypeDeclId.Map.find def_id tyctx in + assert (List.length regions = List.length def.T.region_params); + (* Compute the field types *) + let field_types = + Subst.type_decl_get_instantiated_field_etypes def opt_variant_id types + in + (* Initialize the expanded value *) + let fields = List.map mk_bottom field_types in + let av = V.Adt { variant_id = opt_variant_id; field_values = fields } in + let ty = T.Adt (T.AdtId def_id, regions, types) in + { V.value = av; V.ty } + +(** Compute an expanded Option bottom value *) +let compute_expanded_bottom_option_value (variant_id : T.VariantId.id) + (param_ty : T.ety) : V.typed_value = + (* Note that the variant can be [Some] or [None]: we expand bottom values + * when writing to fields or setting discriminants *) + let field_values = + if variant_id = T.option_some_id then [ mk_bottom param_ty ] + else if variant_id = T.option_none_id then [] + else raise (Failure "Unreachable") + in + let av = V.Adt { variant_id = Some variant_id; field_values } in + let ty = T.Adt (T.Assumed T.Option, [], [ param_ty ]) in + { V.value = av; ty } + +(** Compute an expanded tuple bottom value *) +let compute_expanded_bottom_tuple_value (field_types : T.ety list) : + V.typed_value = + (* Generate the field values *) + let fields = List.map mk_bottom field_types in + let v = V.Adt { variant_id = None; field_values = fields } in + let ty = T.Adt (T.Tuple, [], field_types) in + { V.value = v; V.ty } + +(** Auxiliary helper to expand {!V.Bottom} values. + + During compilation, rustc desaggregates the ADT initializations. The + consequence is that the following rust code: + {[ + let x = Cons a b; + ]} + + Looks like this in MIR: + {[ + (x as Cons).0 = a; + (x as Cons).1 = b; + set_discriminant(x, 0); // If [Cons] is the variant of index 0 + ]} + + The consequence is that we may sometimes need to write fields to values + which are currently {!V.Bottom}. When doing this, we first expand the value + to, say, [Cons Bottom Bottom] (note that field projection contains information + about which variant we should project to, which is why we *can* set the + variant index when writing one of its fields). +*) +let expand_bottom_value_from_projection (config : C.config) + (access : access_kind) (p : E.place) (remaining_pes : int) + (pe : E.projection_elem) (ty : T.ety) (ctx : C.eval_ctx) : C.eval_ctx = + (* Debugging *) + log#ldebug + (lazy + ("expand_bottom_value_from_projection:\n" ^ "pe: " + ^ E.show_projection_elem pe ^ "\n" ^ "ty: " ^ T.show_ety ty)); + (* Prepare the update: we need to take the proper prefix of the place + during whose evaluation we got stuck *) + let projection' = + fst + (Collections.List.split_at p.projection + (List.length p.projection - remaining_pes)) + in + let p' = { p with projection = projection' } in + (* Compute the expanded value. + The type of the {!V.Bottom} value should be a tuple or an ADT. + Note that the projection element we got stuck at should be a + field projection, and gives the variant id if the {!V.Bottom} value + is an enumeration value. + Also, the expanded value should be the proper ADT variant or a tuple + with the proper arity, with all the fields initialized to {!V.Bottom} + *) + let nv = + match (pe, ty) with + (* "Regular" ADTs *) + | ( Field (ProjAdt (def_id, opt_variant_id), _), + T.Adt (T.AdtId def_id', regions, types) ) -> + assert (def_id = def_id'); + compute_expanded_bottom_adt_value ctx.type_context.type_decls def_id + opt_variant_id regions types + (* Option *) + | Field (ProjOption variant_id, _), T.Adt (T.Assumed T.Option, [], [ ty ]) + -> + compute_expanded_bottom_option_value variant_id ty + (* Tuples *) + | Field (ProjTuple arity, _), T.Adt (T.Tuple, [], tys) -> + assert (arity = List.length tys); + (* Generate the field values *) + compute_expanded_bottom_tuple_value tys + | _ -> + failwith + ("Unreachable: " ^ E.show_projection_elem pe ^ ", " ^ T.show_ety ty) + in + (* Update the context by inserting the expanded value at the proper place *) + match write_place config access p' nv ctx with + | Ok ctx -> ctx + | Error _ -> failwith "Unreachable" + +(** Update the environment to be able to read a place. + + When reading a place, we may be stuck along the way because some value + is borrowed, we reach a symbolic value, etc. In this situation [read_place] + fails while returning precise information about the failure. This function + uses this information to update the environment (by ending borrows, + expanding symbolic values) until we manage to fully read the place. + *) +let rec update_ctx_along_read_place (config : C.config) (access : access_kind) + (p : E.place) : cm_fun = + fun cf ctx -> + (* Attempt to read the place: if it fails, update the environment and retry *) + match read_place config access p ctx with + | Ok _ -> cf ctx + | Error err -> + let cc = + match err with + | FailSharedLoan bids -> end_outer_borrows config bids + | FailMutLoan bid -> end_outer_borrow config bid + | FailInactivatedMutBorrow bid -> + activate_inactivated_mut_borrow config bid + | FailSymbolic (i, sp) -> + (* Expand the symbolic value *) + let proj, _ = + Collections.List.split_at p.projection + (List.length p.projection - i) + in + let prefix = { p with projection = proj } in + expand_symbolic_value_no_branching config sp + (Some (Synth.mk_mplace prefix ctx)) + | FailBottom (_, _, _) -> + (* We can't expand {!V.Bottom} values while reading them *) + failwith "Found [Bottom] while reading a place" + | FailBorrow _ -> failwith "Could not read a borrow" + in + comp cc (update_ctx_along_read_place config access p) cf ctx + +(** Update the environment to be able to write to a place. + + See {!update_ctx_along_read_place}. +*) +let rec update_ctx_along_write_place (config : C.config) (access : access_kind) + (p : E.place) : cm_fun = + fun cf ctx -> + (* Attempt to *read* (yes, *read*: we check the access to the place, and + write to it later) the place: if it fails, update the environment and retry *) + match read_place config access p ctx with + | Ok _ -> cf ctx + | Error err -> + (* Update the context *) + let cc = + match err with + | FailSharedLoan bids -> end_outer_borrows config bids + | FailMutLoan bid -> end_outer_borrow config bid + | FailInactivatedMutBorrow bid -> + activate_inactivated_mut_borrow config bid + | FailSymbolic (_pe, sp) -> + (* Expand the symbolic value *) + expand_symbolic_value_no_branching config sp + (Some (Synth.mk_mplace p ctx)) + | FailBottom (remaining_pes, pe, ty) -> + (* Expand the {!V.Bottom} value *) + fun cf ctx -> + let ctx = + expand_bottom_value_from_projection config access p remaining_pes + pe ty ctx + in + cf ctx + | FailBorrow _ -> failwith "Could not write to a borrow" + in + (* Retry *) + comp cc (update_ctx_along_write_place config access p) cf ctx + +(** Small utility used to break control-flow *) +exception UpdateCtx of cm_fun + +(** End the loans at a given place: read the value, if it contains a loan, + end this loan, repeat. + + This is used when reading or borrowing values. We typically + first call {!update_ctx_along_read_place} or {!update_ctx_along_write_place} + to get access to the value, then call this function to "prepare" the value: + when moving values, we can't move a value which contains loans and thus need + to end them, etc. + *) +let rec end_loans_at_place (config : C.config) (access : access_kind) + (p : E.place) : cm_fun = + fun cf ctx -> + (* Iterator to explore a value and update the context whenever we find + * loans. + * We use exceptions to make it handy: whenever we update the + * context, we raise an exception wrapping the updated context. + * *) + let obj = + object + inherit [_] V.iter_typed_value as super + + method! visit_borrow_content env bc = + match bc with + | V.SharedBorrow _ | V.MutBorrow (_, _) -> + (* Nothing special to do *) super#visit_borrow_content env bc + | V.InactivatedMutBorrow (_, bid) -> + (* We need to activate inactivated borrows *) + let cc = activate_inactivated_mut_borrow config bid in + raise (UpdateCtx cc) + + method! visit_loan_content env lc = + match lc with + | V.SharedLoan (bids, v) -> ( + (* End the loans if we need a modification access, otherwise dive into + the shared value *) + match access with + | Read -> super#visit_SharedLoan env bids v + | Write | Move -> + let cc = end_outer_borrows config bids in + raise (UpdateCtx cc)) + | V.MutLoan bid -> + (* We always need to end mutable borrows *) + let cc = end_outer_borrow config bid in + raise (UpdateCtx cc) + end + in + + (* First, retrieve the value *) + match read_place config access p ctx with + | Error _ -> failwith "Unreachable" + | Ok v -> ( + (* Inspect the value and update the context while doing so. + If the context gets updated: perform a recursive call (many things + may have been updated in the context: we need to re-read the value + at place [p] - and this value may actually not be accessible + anymore...) + *) + try + obj#visit_typed_value () v; + (* No context update required: apply the continuation *) + cf ctx + with UpdateCtx cc -> + (* We need to update the context: compose the caugth continuation with + * a recursive call to reinspect the value *) + comp cc (end_loans_at_place config access p) cf ctx) + +(** Drop (end) outer loans and borrows at a given place, which should be + seen as an l-value (we will write to it later, but need to drop + the borrows before writing). + + This is used to drop values when evaluating the drop statement or before + writing to a place. + + [end_borrows]: + - if true: end all the loans and borrows we find, starting with the outer + ones. This is used when evaluating the [drop] statement (see [drop_value]) + - if false: only end the outer loans. This is used by [assign_to_place] + or to drop the loans in the local variables when popping a frame. + + Note that we don't do what is defined in the formalization: we move the + value to a temporary dummy value, then explore this value and end the + loans/borrows inside as long as we find some, starting with the outer + ones, then move the resulting value back to where it was. This shouldn't + make any difference, really (note that the place is *inside* a borrow, + if we end the borrow, we won't be able to reinsert the value back). + *) +let drop_outer_borrows_loans_at_lplace (config : C.config) (end_borrows : bool) + (p : E.place) : cm_fun = + fun cf ctx -> + (* Move the current value in the place outside of this place and into + * a dummy variable *) + let access = Write in + let v = read_place_unwrap config access p ctx in + let ctx = write_place_unwrap config access p (mk_bottom v.V.ty) ctx in + let ctx = C.ctx_push_dummy_var ctx v in + (* Auxiliary function *) + let rec drop : cm_fun = + fun cf ctx -> + (* Read the value *) + let v = C.ctx_read_first_dummy_var ctx in + (* Check if there are loans or borrows to end *) + match get_first_outer_loan_or_borrow_in_value end_borrows v with + | None -> + (* We are done: simply call the continuation *) + cf ctx + | Some c -> + (* There are: end them then retry *) + let cc = + match c with + | LoanContent (V.SharedLoan (bids, _)) -> + end_outer_borrows config bids + | LoanContent (V.MutLoan bid) + | BorrowContent (V.MutBorrow (bid, _) | SharedBorrow (_, bid)) -> + end_outer_borrow config bid + | BorrowContent (V.InactivatedMutBorrow (_, bid)) -> + (* First activate the borrow *) + activate_inactivated_mut_borrow config bid + in + (* Retry *) + comp cc drop cf ctx + in + (* Apply the drop function *) + let cc = drop in + (* Pop the temporary value and reinsert it *) + let cc = + comp cc (fun cf ctx -> + (* Pop *) + let ctx, v = C.ctx_pop_dummy_var ctx in + (* Reinsert *) + let ctx = write_place_unwrap config access p v ctx in + (* Sanity check *) + if end_borrows then ( + assert (not (loans_in_value v)); + assert (not (borrows_in_value v))) + else assert (not (outer_loans_in_value v)); + (* Continue *) + cf ctx) + in + (* Continue *) + cc cf ctx + +(** Copy a value, and return the resulting value. + + Note that copying values might update the context. For instance, when + copying shared borrows, we need to insert new shared borrows in the context. + + Also, this function is actually more general than it should be: it can be used + to copy concrete ADT values, while ADT copy should be done through the Copy + trait (i.e., by calling a dedicated function). This is why we added a parameter + to control this copy. Note that here by ADT we mean the user-defined ADTs + (not tuples or assumed types). + + TODO: move + *) +let rec copy_value (allow_adt_copy : bool) (config : C.config) + (ctx : C.eval_ctx) (v : V.typed_value) : C.eval_ctx * V.typed_value = + log#ldebug + (lazy + ("copy_value: " + ^ typed_value_to_string ctx v + ^ "\n- context:\n" ^ eval_ctx_to_string ctx)); + (* Remark: at some point we rewrote this function to use iterators, but then + * we reverted the changes: the result was less clear actually. In particular, + * the fact that we have exhaustive matches below makes very obvious the cases + * in which we need to fail *) + match v.V.value with + | V.Concrete _ -> (ctx, v) + | V.Adt av -> + (* Sanity check *) + (match v.V.ty with + | T.Adt (T.Assumed (T.Box | Vec), _, _) -> + failwith "Can't copy an assumed value other than Option" + | T.Adt (T.AdtId _, _, _) -> assert allow_adt_copy + | T.Adt ((T.Assumed Option | T.Tuple), _, _) -> () (* Ok *) + | _ -> failwith "Unreachable"); + let ctx, fields = + List.fold_left_map + (copy_value allow_adt_copy config) + ctx av.field_values + in + (ctx, { v with V.value = V.Adt { av with field_values = fields } }) + | V.Bottom -> failwith "Can't copy ⊥" + | V.Borrow bc -> ( + (* We can only copy shared borrows *) + match bc with + | SharedBorrow (mv, bid) -> + (* We need to create a new borrow id for the copied borrow, and + * update the context accordingly *) + let bid' = C.fresh_borrow_id () in + let ctx = reborrow_shared bid bid' ctx in + (ctx, { v with V.value = V.Borrow (SharedBorrow (mv, bid')) }) + | MutBorrow (_, _) -> failwith "Can't copy a mutable borrow" + | V.InactivatedMutBorrow _ -> + failwith "Can't copy an inactivated mut borrow") + | V.Loan lc -> ( + (* We can only copy shared loans *) + match lc with + | V.MutLoan _ -> failwith "Can't copy a mutable loan" + | V.SharedLoan (_, sv) -> + (* We don't copy the shared loan: only the shared value inside *) + copy_value allow_adt_copy config ctx sv) + | V.Symbolic sp -> + (* We can copy only if the type is "primitively" copyable. + * Note that in the general case, copy is a trait: copying values + * thus requires calling the proper function. Here, we copy values + * for very simple types such as integers, shared borrows, etc. *) + assert (ty_is_primitively_copyable (Subst.erase_regions sp.V.sv_ty)); + (* If the type is copyable, we simply return the current value. Side + * remark: what is important to look at when copying symbolic values + * is symbolic expansion. The important subcase is the expansion of shared + * borrows: when doing so, every occurrence of the same symbolic value + * must use a fresh borrow id. *) + (ctx, v) + +(** Small utility. + + Prepare a place which is to be used as the destination of an assignment: + update the environment along the paths, end the loans at this place, etc. + + Return the updated context and the (updated) value at the end of the + place. This value should not contain any loan or borrow (and we check + it is the case). Note that this value is very likely to contain {!V.Bottom} + subvalues. + + [end_borrows]: if false, we only end the outer loans we find. If true, we + end all the loans and the borrows we find. + TODO: end_borrows is not necessary anymore. + *) +let prepare_lplace (config : C.config) (end_borrows : bool) (p : E.place) + (cf : V.typed_value -> m_fun) : m_fun = + fun ctx -> + log#ldebug + (lazy + ("prepare_lplace:" ^ "\n- p: " ^ place_to_string ctx p + ^ "\n- Initial context:\n" ^ eval_ctx_to_string ctx)); + (* Access the place *) + let access = Write in + let cc = update_ctx_along_write_place config access p in + (* End the borrows and loans, starting with the borrows *) + let cc = comp cc (drop_outer_borrows_loans_at_lplace config end_borrows p) in + (* Read the value and check it *) + let read_check cf : m_fun = + fun ctx -> + let v = read_place_unwrap config access p ctx in + (* Sanity checks *) + if end_borrows then ( + assert (not (loans_in_value v)); + assert (not (borrows_in_value v))) + else assert (not (outer_loans_in_value v)); + (* Continue *) + cf v ctx + in + (* Compose and apply the continuations *) + comp cc read_check cf ctx diff --git a/compiler/InterpreterProjectors.ml b/compiler/InterpreterProjectors.ml new file mode 100644 index 00000000..064b8969 --- /dev/null +++ b/compiler/InterpreterProjectors.ml @@ -0,0 +1,543 @@ +module T = Types +module V = Values +module E = Expressions +module C = Contexts +module Subst = Substitute +module L = Logging +open TypesUtils +open InterpreterUtils +open InterpreterBorrowsCore + +(** Auxiliary function. + + Apply a proj_borrows on a shared borrow. + Note that when projecting over shared values, we generate + {!V.abstract_shared_borrows}, not {!V.avalue}s. +*) +let rec apply_proj_borrows_on_shared_borrow (ctx : C.eval_ctx) + (fresh_reborrow : V.BorrowId.id -> V.BorrowId.id) + (regions : T.RegionId.Set.t) (v : V.typed_value) (ty : T.rty) : + V.abstract_shared_borrows = + (* Sanity check - TODO: move this elsewhere (here we perform the check at every + * recursive call which is a bit overkill...) *) + let ety = Subst.erase_regions ty in + assert (ety = v.V.ty); + (* Project - if there are no regions from the abstraction in the type, return [_] *) + if not (ty_has_regions_in_set regions ty) then [] + else + match (v.V.value, ty) with + | V.Concrete _, (T.Bool | T.Char | T.Integer _ | T.Str) -> [] + | V.Adt adt, T.Adt (id, region_params, tys) -> + (* Retrieve the types of the fields *) + let field_types = + Subst.ctx_adt_value_get_instantiated_field_rtypes ctx adt id + region_params tys + in + (* Project over the field values *) + let fields_types = List.combine adt.V.field_values field_types in + let proj_fields = + List.map + (fun (fv, fty) -> + apply_proj_borrows_on_shared_borrow ctx fresh_reborrow regions fv + fty) + fields_types + in + List.concat proj_fields + | V.Bottom, _ -> failwith "Unreachable" + | V.Borrow bc, T.Ref (r, ref_ty, kind) -> + (* Retrieve the bid of the borrow and the asb of the projected borrowed value *) + let bid, asb = + (* Not in the set: dive *) + match (bc, kind) with + | V.MutBorrow (bid, bv), T.Mut -> + (* Apply the projection on the borrowed value *) + let asb = + apply_proj_borrows_on_shared_borrow ctx fresh_reborrow regions + bv ref_ty + in + (bid, asb) + | V.SharedBorrow (_, bid), T.Shared -> + (* Lookup the shared value *) + let ek = ek_all in + let sv = lookup_loan ek bid ctx in + let asb = + match sv with + | _, Concrete (V.SharedLoan (_, sv)) + | _, Abstract (V.ASharedLoan (_, sv, _)) -> + apply_proj_borrows_on_shared_borrow ctx fresh_reborrow + regions sv ref_ty + | _ -> failwith "Unexpected" + in + (bid, asb) + | V.InactivatedMutBorrow _, _ -> + failwith + "Can't apply a proj_borrow over an inactivated mutable borrow" + | _ -> failwith "Unreachable" + in + let asb = + (* Check if the region is in the set of projected regions (note that + * we never project over static regions) *) + if region_in_set r regions then + let bid' = fresh_reborrow bid in + V.AsbBorrow bid' :: asb + else asb + in + asb + | V.Loan _, _ -> failwith "Unreachable" + | V.Symbolic s, _ -> + (* Check that the projection doesn't contain ended regions *) + assert ( + not (projections_intersect s.V.sv_ty ctx.ended_regions ty regions)); + [ V.AsbProjReborrows (s, ty) ] + | _ -> failwith "Unreachable" + +(** Apply (and reduce) a projector over borrows to a value. + + - [regions]: the regions we project + - [v]: the value over which we project + - [ty]: the projection type (is used to map borrows to regions, or to + interpret the borrows as belonging to some regions...). Remember that + [v] doesn't contain region information. + For instance, if we have: + [v <: ty] where: + - [v = mut_borrow l ...] + - [ty = Ref (r, ...)] + then we interpret the borrow [l] as belonging to region [r] + + Also, when applying projections on shared values, we need to apply + reborrows. This is a bit annoying because, with the way we compute + the projection on borrows, we can't update the context immediately. + Instead, we remember the list of borrows we have to insert in the + context *afterwards*. + + [check_symbolic_no_ended] controls whether we check or not whether + symbolic values don't contain already ended regions. + This check is activated when applying projectors upon calling a function + (because we need to check that function arguments don't contain ⊥), + but deactivated when expanding symbolic values: + {[ + fn f<'a,'b>(x : &'a mut u32, y : &'b mut u32) -> (&'a mut u32, &'b mut u32); + + let p = f(&mut x, &mut y); // p -> @s0 + assert(x == ...); // end 'a + let z = p.1; // HERE: the symbolic expansion of @s0 contains ended regions + ]} +*) +let rec apply_proj_borrows (check_symbolic_no_ended : bool) (ctx : C.eval_ctx) + (fresh_reborrow : V.BorrowId.id -> V.BorrowId.id) + (regions : T.RegionId.Set.t) (ancestors_regions : T.RegionId.Set.t) + (v : V.typed_value) (ty : T.rty) : V.typed_avalue = + (* Sanity check - TODO: move this elsewhere (here we perform the check at every + * recursive call which is a bit overkill...) *) + let ety = Substitute.erase_regions ty in + assert (ety = v.V.ty); + (* Project - if there are no regions from the abstraction in the type, return [_] *) + if not (ty_has_regions_in_set regions ty) then { V.value = V.AIgnored; ty } + else + let value : V.avalue = + match (v.V.value, ty) with + | V.Concrete cv, (T.Bool | T.Char | T.Integer _ | T.Str) -> V.AConcrete cv + | V.Adt adt, T.Adt (id, region_params, tys) -> + (* Retrieve the types of the fields *) + let field_types = + Subst.ctx_adt_value_get_instantiated_field_rtypes ctx adt id + region_params tys + in + (* Project over the field values *) + let fields_types = List.combine adt.V.field_values field_types in + let proj_fields = + List.map + (fun (fv, fty) -> + apply_proj_borrows check_symbolic_no_ended ctx fresh_reborrow + regions ancestors_regions fv fty) + fields_types + in + V.AAdt { V.variant_id = adt.V.variant_id; field_values = proj_fields } + | V.Bottom, _ -> failwith "Unreachable" + | V.Borrow bc, T.Ref (r, ref_ty, kind) -> + if + (* Check if the region is in the set of projected regions (note that + * we never project over static regions) *) + region_in_set r regions + then + (* In the set *) + let bc = + match (bc, kind) with + | V.MutBorrow (bid, bv), T.Mut -> + (* Remember the borrowed value we are about to project as a meta-value *) + let mv = bv in + (* Apply the projection on the borrowed value *) + let bv = + apply_proj_borrows check_symbolic_no_ended ctx + fresh_reborrow regions ancestors_regions bv ref_ty + in + V.AMutBorrow (mv, bid, bv) + | V.SharedBorrow (_, bid), T.Shared -> V.ASharedBorrow bid + | V.InactivatedMutBorrow _, _ -> + failwith + "Can't apply a proj_borrow over an inactivated mutable \ + borrow" + | _ -> failwith "Unreachable" + in + V.ABorrow bc + else + (* Not in the set: ignore *) + let bc = + match (bc, kind) with + | V.MutBorrow (bid, bv), T.Mut -> + (* Apply the projection on the borrowed value *) + let bv = + apply_proj_borrows check_symbolic_no_ended ctx + fresh_reborrow regions ancestors_regions bv ref_ty + in + (* If the borrow id is in the ancestor's regions, we still need + * to remember it *) + let opt_bid = + if region_in_set r ancestors_regions then Some bid else None + in + (* Return *) + V.AIgnoredMutBorrow (opt_bid, bv) + | V.SharedBorrow (_, bid), T.Shared -> + (* Lookup the shared value *) + let ek = ek_all in + let sv = lookup_loan ek bid ctx in + let asb = + match sv with + | _, Concrete (V.SharedLoan (_, sv)) + | _, Abstract (V.ASharedLoan (_, sv, _)) -> + apply_proj_borrows_on_shared_borrow ctx fresh_reborrow + regions sv ref_ty + | _ -> failwith "Unexpected" + in + V.AProjSharedBorrow asb + | V.InactivatedMutBorrow _, _ -> + failwith + "Can't apply a proj_borrow over an inactivated mutable \ + borrow" + | _ -> failwith "Unreachable" + in + V.ABorrow bc + | V.Loan _, _ -> failwith "Unreachable" + | V.Symbolic s, _ -> + (* Check that the projection doesn't contain already ended regions, + * if necessary *) + if check_symbolic_no_ended then ( + let ty1 = s.V.sv_ty in + let rset1 = ctx.ended_regions in + let ty2 = ty in + let rset2 = regions in + log#ldebug + (lazy + ("projections_intersect:" ^ "\n- ty1: " ^ rty_to_string ctx ty1 + ^ "\n- rset1: " + ^ T.RegionId.Set.to_string None rset1 + ^ "\n- ty2: " ^ rty_to_string ctx ty2 ^ "\n- rset2: " + ^ T.RegionId.Set.to_string None rset2 + ^ "\n")); + assert (not (projections_intersect ty1 rset1 ty2 rset2))); + V.ASymbolic (V.AProjBorrows (s, ty)) + | _ -> + log#lerror + (lazy + ("apply_proj_borrows: unexpected inputs:\n- input value: " + ^ typed_value_to_string ctx v + ^ "\n- proj rty: " ^ rty_to_string ctx ty)); + failwith "Unreachable" + in + { V.value; V.ty } + +(** Convert a symbolic expansion *which is not a borrow* to a value *) +let symbolic_expansion_non_borrow_to_value (sv : V.symbolic_value) + (see : V.symbolic_expansion) : V.typed_value = + let ty = Subst.erase_regions sv.V.sv_ty in + let value = + match see with + | SeConcrete cv -> V.Concrete cv + | SeAdt (variant_id, field_values) -> + let field_values = + List.map mk_typed_value_from_symbolic_value field_values + in + V.Adt { V.variant_id; V.field_values } + | SeMutRef (_, _) | SeSharedRef (_, _) -> + failwith "Unexpected symbolic reference expansion" + in + { V.value; V.ty } + +(** Convert a symbolic expansion to a value. + + If the expansion is a mutable reference expansion, it converts it to a borrow. + This function is meant to be used when reducing projectors over borrows, + during a symbolic expansion. + *) +let symbolic_expansion_non_shared_borrow_to_value (sv : V.symbolic_value) + (see : V.symbolic_expansion) : V.typed_value = + match see with + | SeMutRef (bid, bv) -> + let ty = Subst.erase_regions sv.V.sv_ty in + let bv = mk_typed_value_from_symbolic_value bv in + let value = V.Borrow (V.MutBorrow (bid, bv)) in + { V.value; ty } + | SeSharedRef (_, _) -> + failwith "Unexpected symbolic shared reference expansion" + | _ -> symbolic_expansion_non_borrow_to_value sv see + +(** Apply (and reduce) a projector over loans to a value. + + TODO: detailed comments. See [apply_proj_borrows] +*) +let apply_proj_loans_on_symbolic_expansion (regions : T.RegionId.Set.t) + (see : V.symbolic_expansion) (original_sv_ty : T.rty) : V.typed_avalue = + (* Sanity check: if we have a proj_loans over a symbolic value, it should + * contain regions which we will project *) + assert (ty_has_regions_in_set regions original_sv_ty); + (* Match *) + let (value, ty) : V.avalue * T.rty = + match (see, original_sv_ty) with + | SeConcrete _, (T.Bool | T.Char | T.Integer _ | T.Str) -> + (V.AIgnored, original_sv_ty) + | SeAdt (variant_id, field_values), T.Adt (_id, _region_params, _tys) -> + (* Project over the field values *) + let field_values = + List.map + (mk_aproj_loans_value_from_symbolic_value regions) + field_values + in + (V.AAdt { V.variant_id; field_values }, original_sv_ty) + | SeMutRef (bid, spc), T.Ref (r, ref_ty, T.Mut) -> + (* Sanity check *) + assert (spc.V.sv_ty = ref_ty); + (* Apply the projector to the borrowed value *) + let child_av = mk_aproj_loans_value_from_symbolic_value regions spc in + (* Check if the region is in the set of projected regions (note that + * we never project over static regions) *) + if region_in_set r regions then + (* In the set: keep *) + (V.ALoan (V.AMutLoan (bid, child_av)), ref_ty) + else + (* Not in the set: ignore *) + (V.ALoan (V.AIgnoredMutLoan (bid, child_av)), ref_ty) + | SeSharedRef (bids, spc), T.Ref (r, ref_ty, T.Shared) -> + (* Sanity check *) + assert (spc.V.sv_ty = ref_ty); + (* Apply the projector to the borrowed value *) + let child_av = mk_aproj_loans_value_from_symbolic_value regions spc in + (* Check if the region is in the set of projected regions (note that + * we never project over static regions) *) + if region_in_set r regions then + (* In the set: keep *) + let shared_value = mk_typed_value_from_symbolic_value spc in + (V.ALoan (V.ASharedLoan (bids, shared_value, child_av)), ref_ty) + else + (* Not in the set: ignore *) + (V.ALoan (V.AIgnoredSharedLoan child_av), ref_ty) + | _ -> failwith "Unreachable" + in + { V.value; V.ty } + +(** Auxiliary function. See [give_back_value]. + + Apply reborrows to a context. + + The [reborrows] input is a list of pairs (shared loan id, id to insert + in the shared loan). + This function is used when applying projectors on shared borrows: when + doing so, we might need to reborrow subvalues from the shared value. + For instance: + {[ + fn f<'a,'b,'c>(x : &'a 'b 'c u32) + ]} + When introducing the abstractions for 'a, 'b and 'c, we apply a projector + on some value [shared_borrow l : &'a &'b &'c u32]. + In the 'a abstraction, this shared borrow gets projected. However, when + reducing the projectors for the 'b and 'c abstractions, we need to make + sure that the borrows living in regions 'b and 'c live as long as those + regions. This is done by looking up the shared value and applying reborrows + on the borrows we find there (note that those reborrows apply on shared + borrows - easy - and mutable borrows - in this case, we reborrow the whole + borrow: [mut_borrow ... ~~> shared_loan {...} (mut_borrow ...)]). +*) +let apply_reborrows (reborrows : (V.BorrowId.id * V.BorrowId.id) list) + (ctx : C.eval_ctx) : C.eval_ctx = + (* This is a bit brutal, but whenever we insert a reborrow, we remove + * it from the list. This allows us to check that all the reborrows were + * applied before returning. + * We might reimplement that in a more efficient manner by using maps. *) + let reborrows = ref reborrows in + + (* Check if a value is a mutable borrow, and return its identifier if + it is the case *) + let get_borrow_in_mut_borrow (v : V.typed_value) : V.BorrowId.id option = + match v.V.value with + | V.Borrow lc -> ( + match lc with + | V.SharedBorrow (_, _) | V.InactivatedMutBorrow _ -> None + | V.MutBorrow (id, _) -> Some id) + | _ -> None + in + + (* Add the proper reborrows to a set of borrow ids (for a shared loan) *) + let insert_reborrows bids = + (* Find the reborrows to apply *) + let insert, reborrows' = + List.partition (fun (bid, _) -> V.BorrowId.Set.mem bid bids) !reborrows + in + reborrows := reborrows'; + let insert = List.map snd insert in + (* Insert the borrows *) + List.fold_left (fun bids bid -> V.BorrowId.Set.add bid bids) bids insert + in + + (* Get the list of reborrows for a given borrow id *) + let get_reborrows_for_bid bid = + (* Find the reborrows to apply *) + let insert, reborrows' = + List.partition (fun (bid', _) -> bid' = bid) !reborrows + in + reborrows := reborrows'; + List.map snd insert + in + + let borrows_to_set bids = + List.fold_left + (fun bids bid -> V.BorrowId.Set.add bid bids) + V.BorrowId.Set.empty bids + in + + (* Insert reborrows for a given borrow id into a given set of borrows *) + let insert_reborrows_for_bid bids bid = + (* Find the reborrows to apply *) + let insert = get_reborrows_for_bid bid in + (* Insert the borrows *) + List.fold_left (fun bids bid -> V.BorrowId.Set.add bid bids) bids insert + in + + let obj = + object + inherit [_] C.map_eval_ctx as super + + (** We may need to reborrow mutable borrows. Note that this doesn't + happen for aborrows *) + method! visit_typed_value env v = + match v.V.value with + | V.Borrow (V.MutBorrow (bid, bv)) -> + let insert = get_reborrows_for_bid bid in + let nbc = super#visit_MutBorrow env bid bv in + let nbc = { v with V.value = V.Borrow nbc } in + if insert = [] then (* No reborrows: do nothing special *) + nbc + else + (* There are reborrows: insert a shared loan *) + let insert = borrows_to_set insert in + let value = V.Loan (V.SharedLoan (insert, nbc)) in + let ty = v.V.ty in + { V.value; ty } + | _ -> super#visit_typed_value env v + + (** We reimplement {!visit_loan_content} (rather than one of the sub- + functions) on purpose: exhaustive matches are good for maintenance *) + method! visit_loan_content env lc = + match lc with + | V.SharedLoan (bids, sv) -> + (* Insert the reborrows *) + let bids = insert_reborrows bids in + (* Check if the contained value is a mutable borrow, in which + * case we might need to reborrow it by adding more borrow ids + * to the current set of borrows - by doing this small + * manipulation here, we accumulate the borrow ids in the same + * shared loan, right above the mutable borrow, and avoid + * stacking shared loans (note that doing this is not a problem + * from a soundness point of view, but it is a bit ugly...) *) + let bids = + match get_borrow_in_mut_borrow sv with + | None -> bids + | Some bid -> insert_reborrows_for_bid bids bid + in + (* Update and explore *) + super#visit_SharedLoan env bids sv + | V.MutLoan bid -> + (* Nothing special to do *) + super#visit_MutLoan env bid + + method! visit_aloan_content env lc = + match lc with + | V.ASharedLoan (bids, sv, av) -> + (* Insert the reborrows *) + let bids = insert_reborrows bids in + (* Similarly to the non-abstraction case: check if the shared + * value is a mutable borrow, to eventually insert more reborrows *) + (* Update and explore *) + let bids = + match get_borrow_in_mut_borrow sv with + | None -> bids + | Some bid -> insert_reborrows_for_bid bids bid + in + (* Update and explore *) + super#visit_ASharedLoan env bids sv av + | V.AIgnoredSharedLoan _ + | V.AMutLoan (_, _) + | V.AEndedMutLoan { given_back = _; child = _; given_back_meta = _ } + | V.AEndedSharedLoan (_, _) + | V.AIgnoredMutLoan (_, _) + | V.AEndedIgnoredMutLoan + { given_back = _; child = _; given_back_meta = _ } -> + (* Nothing particular to do *) + super#visit_aloan_content env lc + end + in + + (* Visit *) + let ctx = obj#visit_eval_ctx () ctx in + (* Check that there are no reborrows remaining *) + assert (!reborrows = []); + (* Return *) + ctx + +(** Auxiliary function to prepare reborrowing operations (used when + applying projectors). + + Returns two functions: + - a function to generate fresh re-borrow ids, and register the reborrows + - a function to apply the reborrows in a context + Those functions are of course stateful. + *) +let prepare_reborrows (config : C.config) (allow_reborrows : bool) : + (V.BorrowId.id -> V.BorrowId.id) * (C.eval_ctx -> C.eval_ctx) = + let reborrows : (V.BorrowId.id * V.BorrowId.id) list ref = ref [] in + (* The function to generate and register fresh reborrows *) + let fresh_reborrow (bid : V.BorrowId.id) : V.BorrowId.id = + if allow_reborrows then ( + let bid' = C.fresh_borrow_id () in + reborrows := (bid, bid') :: !reborrows; + bid') + else failwith "Unexpected reborrow" + in + (* The function to apply the reborrows in a context *) + let apply_registered_reborrows (ctx : C.eval_ctx) : C.eval_ctx = + match config.C.mode with + | C.ConcreteMode -> + assert (!reborrows = []); + ctx + | C.SymbolicMode -> + (* Apply the reborrows *) + apply_reborrows !reborrows ctx + in + (fresh_reborrow, apply_registered_reborrows) + +let apply_proj_borrows_on_input_value (config : C.config) (ctx : C.eval_ctx) + (regions : T.RegionId.Set.t) (ancestors_regions : T.RegionId.Set.t) + (v : V.typed_value) (ty : T.rty) : C.eval_ctx * V.typed_avalue = + let check_symbolic_no_ended = true in + let allow_reborrows = true in + (* Prepare the reborrows *) + let fresh_reborrow, apply_registered_reborrows = + prepare_reborrows config allow_reborrows + in + (* Apply the projector *) + let av = + apply_proj_borrows check_symbolic_no_ended ctx fresh_reborrow regions + ancestors_regions v ty + in + (* Apply the reborrows *) + let ctx = apply_registered_reborrows ctx in + (* Return *) + (ctx, av) diff --git a/compiler/InterpreterStatements.ml b/compiler/InterpreterStatements.ml new file mode 100644 index 00000000..4e61e683 --- /dev/null +++ b/compiler/InterpreterStatements.ml @@ -0,0 +1,1370 @@ +module T = Types +module V = Values +module E = Expressions +module C = Contexts +module Subst = Substitute +module A = LlbcAst +module L = Logging +open TypesUtils +open ValuesUtils +module Inv = Invariants +module S = SynthesizeSymbolic +open Errors +open Cps +open InterpreterUtils +open InterpreterProjectors +open InterpreterExpansion +open InterpreterPaths +open InterpreterExpressions + +(** The local logger *) +let log = L.statements_log + +(** Drop a value at a given place - TODO: factorize this with [assign_to_place] *) +let drop_value (config : C.config) (p : E.place) : cm_fun = + fun cf ctx -> + log#ldebug + (lazy + ("drop_value: place: " ^ place_to_string ctx p ^ "\n- Initial context:\n" + ^ eval_ctx_to_string ctx)); + (* Prepare the place (by ending the outer loans). + * Note that {!prepare_lplace} will use the [Write] access kind: + * it is ok, because when updating the value with {!Bottom} below, + * we will use the [Move] access *) + let end_borrows = false in + let prepare = prepare_lplace config end_borrows p in + (* Replace the value with {!Bottom} *) + let replace cf (v : V.typed_value) ctx = + (* Move the value at destination (that we will overwrite) to a dummy variable + * to preserve the borrows *) + let mv = read_place_unwrap config Write p ctx in + let ctx = C.ctx_push_dummy_var ctx mv in + (* Update the destination to ⊥ *) + let nv = { v with value = V.Bottom } in + let ctx = write_place_unwrap config Move p nv ctx in + log#ldebug + (lazy + ("drop_value: place: " ^ place_to_string ctx p ^ "\n- Final context:\n" + ^ eval_ctx_to_string ctx)); + cf ctx + in + (* Compose and apply *) + comp prepare replace cf ctx + +(** Push a dummy variable to the environment *) +let push_dummy_var (v : V.typed_value) : cm_fun = + fun cf ctx -> + let ctx = C.ctx_push_dummy_var ctx v in + cf ctx + +(** Pop a dummy variable from the environment *) +let pop_dummy_var (cf : V.typed_value -> m_fun) : m_fun = + fun ctx -> + let ctx, v = C.ctx_pop_dummy_var ctx in + cf v ctx + +(** Push an uninitialized variable to the environment *) +let push_uninitialized_var (var : A.var) : cm_fun = + fun cf ctx -> + let ctx = C.ctx_push_uninitialized_var ctx var in + cf ctx + +(** Push a list of uninitialized variables to the environment *) +let push_uninitialized_vars (vars : A.var list) : cm_fun = + fun cf ctx -> + let ctx = C.ctx_push_uninitialized_vars ctx vars in + cf ctx + +(** Push a variable to the environment *) +let push_var (var : A.var) (v : V.typed_value) : cm_fun = + fun cf ctx -> + let ctx = C.ctx_push_var ctx var v in + cf ctx + +(** Push a list of variables to the environment *) +let push_vars (vars : (A.var * V.typed_value) list) : cm_fun = + fun cf ctx -> + let ctx = C.ctx_push_vars ctx vars in + cf ctx + +(** Assign a value to a given place. + + Note that this function first pushes the value to assign in a dummy variable, + then prepares the destination (by ending borrows, etc.) before popping the + dummy variable and putting in its destination (after having checked that + preparing the destination didn't introduce ⊥). + *) +let assign_to_place (config : C.config) (rv : V.typed_value) (p : E.place) : + cm_fun = + fun cf ctx -> + log#ldebug + (lazy + ("assign_to_place:" ^ "\n- rv: " + ^ typed_value_to_string ctx rv + ^ "\n- p: " ^ place_to_string ctx p ^ "\n- Initial context:\n" + ^ eval_ctx_to_string ctx)); + (* Push the rvalue to a dummy variable, for bookkeeping *) + let cc = push_dummy_var rv in + (* Prepare the destination *) + let end_borrows = false in + let cc = comp cc (prepare_lplace config end_borrows p) in + (* Retrieve the rvalue from the dummy variable *) + let cc = comp cc (fun cf _lv -> pop_dummy_var cf) in + (* Update the destination *) + let move_dest cf (rv : V.typed_value) : m_fun = + fun ctx -> + (* Move the value at destination (that we will overwrite) to a dummy variable + * to preserve the borrows *) + let mv = read_place_unwrap config Write p ctx in + let ctx = C.ctx_push_dummy_var ctx mv in + (* Write to the destination *) + (* Checks - maybe the bookkeeping updated the rvalue and introduced bottoms *) + assert (not (bottom_in_value ctx.ended_regions rv)); + (* Update the destination *) + let ctx = write_place_unwrap config Write p rv ctx in + (* Debug *) + log#ldebug + (lazy + ("assign_to_place:" ^ "\n- rv: " + ^ typed_value_to_string ctx rv + ^ "\n- p: " ^ place_to_string ctx p ^ "\n- Final context:\n" + ^ eval_ctx_to_string ctx)); + (* Continue *) + cf ctx + in + (* Compose and apply *) + comp cc move_dest cf ctx + +(** Evaluate an assertion, when the scrutinee is not symbolic *) +let eval_assertion_concrete (config : C.config) (assertion : A.assertion) : + st_cm_fun = + fun cf ctx -> + (* There won't be any symbolic expansions: fully evaluate the operand *) + let eval_op = eval_operand config assertion.cond in + let eval_assert cf (v : V.typed_value) : m_fun = + fun ctx -> + match v.value with + | Concrete (Bool b) -> + (* Branch *) + if b = assertion.expected then cf Unit ctx else cf Panic ctx + | _ -> + raise + (Failure ("Expected a boolean, got: " ^ typed_value_to_string ctx v)) + in + (* Compose and apply *) + comp eval_op eval_assert cf ctx + +(** Evaluates an assertion. + + In the case the boolean under scrutinee is symbolic, we synthesize + a call to [assert ...] then continue in the success branch (and thus + expand the boolean to [true]). + *) +let eval_assertion (config : C.config) (assertion : A.assertion) : st_cm_fun = + fun cf ctx -> + (* Evaluate the operand *) + let eval_op = eval_operand config assertion.cond in + (* Evaluate the assertion *) + let eval_assert cf (v : V.typed_value) : m_fun = + fun ctx -> + assert (v.ty = T.Bool); + (* We make a choice here: we could completely decouple the concrete and + * symbolic executions here but choose not to. In the case where we + * know the concrete value of the boolean we test, we use this value + * even if we are in symbolic mode. Note that this case should be + * extremely rare... *) + match v.value with + | Concrete (Bool _) -> + (* Delegate to the concrete evaluation function *) + eval_assertion_concrete config assertion cf ctx + | Symbolic sv -> + assert (config.mode = C.SymbolicMode); + assert (sv.V.sv_ty = T.Bool); + (* Expand the symbolic value and call the proper continuation functions + * for the true and false cases - TODO: call an "assert" function instead *) + let cf_true : m_fun = fun ctx -> cf Unit ctx in + let cf_false : m_fun = fun ctx -> cf Panic ctx in + let expand = + expand_symbolic_bool config sv + (S.mk_opt_place_from_op assertion.cond ctx) + cf_true cf_false + in + expand ctx + | _ -> + raise + (Failure ("Expected a boolean, got: " ^ typed_value_to_string ctx v)) + in + (* Compose and apply *) + comp eval_op eval_assert cf ctx + +(** Updates the discriminant of a value at a given place. + + There are two situations: + - either the discriminant is already the proper one (in which case we + don't do anything) + - or it is not the proper one (because the variant is not the proper + one, or the value is actually {!V.Bottom} - this happens when + initializing ADT values), in which case we replace the value with + a variant with all its fields set to {!V.Bottom}. + For instance, something like: [Cons Bottom Bottom]. + *) +let set_discriminant (config : C.config) (p : E.place) + (variant_id : T.VariantId.id) : st_cm_fun = + fun cf ctx -> + log#ldebug + (lazy + ("set_discriminant:" ^ "\n- p: " ^ place_to_string ctx p + ^ "\n- variant id: " + ^ T.VariantId.to_string variant_id + ^ "\n- initial context:\n" ^ eval_ctx_to_string ctx)); + (* Access the value *) + let access = Write in + let cc = update_ctx_along_read_place config access p in + let end_borrows = false in + let cc = comp cc (prepare_lplace config end_borrows p) in + (* Update the value *) + let update_value cf (v : V.typed_value) : m_fun = + fun ctx -> + match (v.V.ty, v.V.value) with + | ( T.Adt (((T.AdtId _ | T.Assumed T.Option) as type_id), regions, types), + V.Adt av ) -> ( + (* There are two situations: + - either the discriminant is already the proper one (in which case we + don't do anything) + - or it is not the proper one, in which case we replace the value with + a variant with all its fields set to {!Bottom} + *) + match av.variant_id with + | None -> raise (Failure "Found a struct value while expected an enum") + | Some variant_id' -> + if variant_id' = variant_id then (* Nothing to do *) + cf Unit ctx + else + (* Replace the value *) + let bottom_v = + match type_id with + | T.AdtId def_id -> + compute_expanded_bottom_adt_value + ctx.type_context.type_decls def_id (Some variant_id) + regions types + | T.Assumed T.Option -> + assert (regions = []); + compute_expanded_bottom_option_value variant_id + (Collections.List.to_cons_nil types) + | _ -> raise (Failure "Unreachable") + in + assign_to_place config bottom_v p (cf Unit) ctx) + | ( T.Adt (((T.AdtId _ | T.Assumed T.Option) as type_id), regions, types), + V.Bottom ) -> + let bottom_v = + match type_id with + | T.AdtId def_id -> + compute_expanded_bottom_adt_value ctx.type_context.type_decls + def_id (Some variant_id) regions types + | T.Assumed T.Option -> + assert (regions = []); + compute_expanded_bottom_option_value variant_id + (Collections.List.to_cons_nil types) + | _ -> raise (Failure "Unreachable") + in + assign_to_place config bottom_v p (cf Unit) ctx + | _, V.Symbolic _ -> + assert (config.mode = SymbolicMode); + (* This is a bit annoying: in theory we should expand the symbolic value + * then set the discriminant, because in the case the discriminant is + * exactly the one we set, the fields are left untouched, and in the + * other cases they are set to Bottom. + * For now, we forbid setting the discriminant of a symbolic value: + * setting a discriminant should only be used to initialize a value, + * or reset an already initialized value, really. *) + raise (Failure "Unexpected value") + | _, (V.Adt _ | V.Bottom) -> raise (Failure "Inconsistent state") + | _, (V.Concrete _ | V.Borrow _ | V.Loan _) -> + raise (Failure "Unexpected value") + in + (* Compose and apply *) + comp cc update_value cf ctx + +(** Push a frame delimiter in the context's environment *) +let ctx_push_frame (ctx : C.eval_ctx) : C.eval_ctx = + { ctx with env = Frame :: ctx.env } + +(** Push a frame delimiter in the context's environment *) +let push_frame : cm_fun = fun cf ctx -> cf (ctx_push_frame ctx) + +(** Small helper: compute the type of the return value for a specific + instantiation of a non-local function. + *) +let get_non_local_function_return_type (fid : A.assumed_fun_id) + (region_params : T.erased_region list) (type_params : T.ety list) : T.ety = + (* [Box::free] has a special treatment *) + match (fid, region_params, type_params) with + | A.BoxFree, [], [ _ ] -> mk_unit_ty + | _ -> + (* Retrieve the function's signature *) + let sg = Assumed.get_assumed_sig fid in + (* Instantiate the return type *) + let tsubst = + Subst.make_type_subst + (List.map (fun v -> v.T.index) sg.type_params) + type_params + in + Subst.erase_regions_substitute_types tsubst sg.output + +let move_return_value (config : C.config) (cf : V.typed_value -> m_fun) : m_fun + = + fun ctx -> + let ret_vid = V.VarId.zero in + let cc = eval_operand config (E.Move (mk_place_from_var_id ret_vid)) in + cc cf ctx + +(** Pop the current frame. + + Drop all the local variables but the return variable, move the return + value out of the return variable, remove all the local variables (but not the + abstractions!) from the context, remove the {!C.Frame} indicator delimiting the + current frame and handle the return value to the continuation. + + TODO: rename (remove the "ctx_") + *) +let ctx_pop_frame (config : C.config) (cf : V.typed_value -> m_fun) : m_fun = + fun ctx -> + (* Debug *) + log#ldebug (lazy ("ctx_pop_frame:\n" ^ eval_ctx_to_string ctx)); + + (* List the local variables, but the return variable *) + let ret_vid = V.VarId.zero in + let rec list_locals env = + match env with + | [] -> raise (Failure "Inconsistent environment") + | C.Abs _ :: env -> list_locals env + | C.Var (None, _) :: env -> list_locals env + | C.Var (Some var, _) :: env -> + let locals = list_locals env in + if var.index <> ret_vid then var.index :: locals else locals + | C.Frame :: _ -> [] + in + let locals : V.VarId.id list = list_locals ctx.env in + (* Debug *) + log#ldebug + (lazy + ("ctx_pop_frame: locals in which to drop the outer loans: [" + ^ String.concat "," (List.map V.VarId.to_string locals) + ^ "]")); + + (* Move the return value out of the return variable *) + let cc = move_return_value config in + (* Sanity check *) + let cc = + comp_check_value cc (fun ret_value ctx -> + assert (not (bottom_in_value ctx.ended_regions ret_value))) + in + + (* Drop the outer *loans* we find in the local variables *) + let cf_drop_loans_in_locals cf (ret_value : V.typed_value) : m_fun = + (* Drop the loans *) + let end_borrows = false in + let locals = List.rev locals in + let cf_drop = + List.fold_left + (fun cf lid -> + drop_outer_borrows_loans_at_lplace config end_borrows + (mk_place_from_var_id lid) cf) + (cf ret_value) locals + in + (* Apply *) + cf_drop + in + let cc = comp cc cf_drop_loans_in_locals in + (* Debug *) + let cc = + comp_check_value cc (fun _ ctx -> + log#ldebug + (lazy + ("ctx_pop_frame: after dropping outer loans in local variables:\n" + ^ eval_ctx_to_string ctx))) + in + + (* Pop the frame - we remove the [Frame] delimiter, and reintroduce all + * the local variables (which may still contain borrow permissions - but + * no outer loans) as dummy variables in the caller frame *) + let rec pop env = + match env with + | [] -> raise (Failure "Inconsistent environment") + | C.Abs abs :: env -> C.Abs abs :: pop env + | C.Var (_, v) :: env -> C.Var (None, v) :: pop env + | C.Frame :: env -> (* Stop here *) env + in + let cf_pop cf (ret_value : V.typed_value) : m_fun = + fun ctx -> + let env = pop ctx.env in + let ctx = { ctx with env } in + cf ret_value ctx + in + (* Compose and apply *) + comp cc cf_pop cf ctx + +(** Pop the current frame and assign the returned value to its destination. *) +let pop_frame_assign (config : C.config) (dest : E.place) : cm_fun = + let cf_pop = ctx_pop_frame config in + let cf_assign cf ret_value : m_fun = + assign_to_place config ret_value dest cf + in + comp cf_pop cf_assign + +(** Auxiliary function - see [eval_non_local_function_call] *) +let eval_replace_concrete (_config : C.config) + (_region_params : T.erased_region list) (_type_params : T.ety list) : cm_fun + = + fun _cf _ctx -> raise Unimplemented + +(** Auxiliary function - see [eval_non_local_function_call] *) +let eval_box_new_concrete (config : C.config) + (region_params : T.erased_region list) (type_params : T.ety list) : cm_fun = + fun cf ctx -> + (* Check and retrieve the arguments *) + match (region_params, type_params, ctx.env) with + | ( [], + [ boxed_ty ], + Var (Some input_var, input_value) :: Var (_ret_var, _) :: C.Frame :: _ ) + -> + (* Required type checking *) + assert (input_value.V.ty = boxed_ty); + + (* Move the input value *) + let cf_move = + eval_operand config (E.Move (mk_place_from_var_id input_var.C.index)) + in + + (* Create the new box *) + let cf_create cf (moved_input_value : V.typed_value) : m_fun = + (* Create the box value *) + let box_ty = T.Adt (T.Assumed T.Box, [], [ boxed_ty ]) in + let box_v = + V.Adt { variant_id = None; field_values = [ moved_input_value ] } + in + let box_v = mk_typed_value box_ty box_v in + + (* Move this value to the return variable *) + let dest = mk_place_from_var_id V.VarId.zero in + let cf_assign = assign_to_place config box_v dest in + + (* Continue *) + cf_assign cf + in + + (* Compose and apply *) + comp cf_move cf_create cf ctx + | _ -> raise (Failure "Inconsistent state") + +(** Auxiliary function which factorizes code to evaluate [std::Deref::deref] + and [std::DerefMut::deref_mut] - see [eval_non_local_function_call] *) +let eval_box_deref_mut_or_shared_concrete (config : C.config) + (region_params : T.erased_region list) (type_params : T.ety list) + (is_mut : bool) : cm_fun = + fun cf ctx -> + (* Check the arguments *) + match (region_params, type_params, ctx.env) with + | ( [], + [ boxed_ty ], + Var (Some input_var, input_value) :: Var (_ret_var, _) :: C.Frame :: _ ) + -> + (* Required type checking. We must have: + - input_value.ty == & (mut) Box + - boxed_ty == ty + for some ty + *) + (let _, input_ty, ref_kind = ty_get_ref input_value.V.ty in + assert (match ref_kind with T.Shared -> not is_mut | T.Mut -> is_mut); + let input_ty = ty_get_box input_ty in + assert (input_ty = boxed_ty)); + + (* Borrow the boxed value *) + let p = + { E.var_id = input_var.C.index; projection = [ E.Deref; E.DerefBox ] } + in + let borrow_kind = if is_mut then E.Mut else E.Shared in + let rv = E.Ref (p, borrow_kind) in + let cf_borrow = eval_rvalue config rv in + + (* Move the borrow to its destination *) + let cf_move cf res : m_fun = + match res with + | Error EPanic -> + (* We can't get there by borrowing a value *) + raise (Failure "Unreachable") + | Ok borrowed_value -> + (* Move and continue *) + let destp = mk_place_from_var_id V.VarId.zero in + assign_to_place config borrowed_value destp cf + in + + (* Compose and apply *) + comp cf_borrow cf_move cf ctx + | _ -> raise (Failure "Inconsistent state") + +(** Auxiliary function - see [eval_non_local_function_call] *) +let eval_box_deref_concrete (config : C.config) + (region_params : T.erased_region list) (type_params : T.ety list) : cm_fun = + let is_mut = false in + eval_box_deref_mut_or_shared_concrete config region_params type_params is_mut + +(** Auxiliary function - see [eval_non_local_function_call] *) +let eval_box_deref_mut_concrete (config : C.config) + (region_params : T.erased_region list) (type_params : T.ety list) : cm_fun = + let is_mut = true in + eval_box_deref_mut_or_shared_concrete config region_params type_params is_mut + +(** Auxiliary function - see [eval_non_local_function_call]. + + [Box::free] is not handled the same way as the other assumed functions: + - in the regular case, whenever we need to evaluate an assumed function, + we evaluate the operands, push a frame, call a dedicated function + to correctly update the variables in the frame (and mimic the execution + of a body) and finally pop the frame + - in the case of [Box::free]: the value given to this function is often + of the form [Box(⊥)] because we can move the value out of the + box before freeing the box. It makes it invalid to see box_free as a + "regular" function: it is not valid to call a function with arguments + which contain [⊥]. For this reason, we execute [Box::free] as drop_value, + but this is a bit annoying with regards to the semantics... + + Followingly this function doesn't behave like the others: it does not expect + a stack frame to have been pushed, but rather simply behaves like {!drop_value}. + It thus updates the box value (by calling {!drop_value}) and updates + the destination (by setting it to [()]). +*) +let eval_box_free (config : C.config) (region_params : T.erased_region list) + (type_params : T.ety list) (args : E.operand list) (dest : E.place) : cm_fun + = + fun cf ctx -> + match (region_params, type_params, args) with + | [], [ boxed_ty ], [ E.Move input_box_place ] -> + (* Required type checking *) + let input_box = read_place_unwrap config Write input_box_place ctx in + (let input_ty = ty_get_box input_box.V.ty in + assert (input_ty = boxed_ty)); + + (* Drop the value *) + let cc = drop_value config input_box_place in + + (* Update the destination by setting it to [()] *) + let cc = comp cc (assign_to_place config mk_unit_value dest) in + + (* Continue *) + cc cf ctx + | _ -> raise (Failure "Inconsistent state") + +(** Auxiliary function - see [eval_non_local_function_call] *) +let eval_vec_function_concrete (_config : C.config) (_fid : A.assumed_fun_id) + (_region_params : T.erased_region list) (_type_params : T.ety list) : cm_fun + = + fun _cf _ctx -> raise Unimplemented + +(** Evaluate a non-local function call in concrete mode *) +let eval_non_local_function_call_concrete (config : C.config) + (fid : A.assumed_fun_id) (region_params : T.erased_region list) + (type_params : T.ety list) (args : E.operand list) (dest : E.place) : cm_fun + = + (* There are two cases (and this is extremely annoying): + - the function is not box_free + - the function is box_free + See {!eval_box_free} + *) + match fid with + | A.BoxFree -> + (* Degenerate case: box_free *) + eval_box_free config region_params type_params args dest + | _ -> + (* "Normal" case: not box_free *) + (* Evaluate the operands *) + (* let ctx, args_vl = eval_operands config ctx args in *) + let cf_eval_ops = eval_operands config args in + + (* Evaluate the call + * + * Style note: at some point we used {!comp_transmit} to + * transmit the result of {!eval_operands} above down to {!push_vars} + * below, without having to introduce an intermediary function call, + * but it made it less clear where the computed values came from, + * so we reversed the modifications. *) + let cf_eval_call cf (args_vl : V.typed_value list) : m_fun = + (* Push the stack frame: we initialize the frame with the return variable, + and one variable per input argument *) + let cc = push_frame in + + (* Create and push the return variable *) + let ret_vid = V.VarId.zero in + let ret_ty = + get_non_local_function_return_type fid region_params type_params + in + let ret_var = mk_var ret_vid (Some "@return") ret_ty in + let cc = comp cc (push_uninitialized_var ret_var) in + + (* Create and push the input variables *) + let input_vars = + V.VarId.mapi_from1 + (fun id (v : V.typed_value) -> (mk_var id None v.V.ty, v)) + args_vl + in + let cc = comp cc (push_vars input_vars) in + + (* "Execute" the function body. As the functions are assumed, here we call + * custom functions to perform the proper manipulations: we don't have + * access to a body. *) + let cf_eval_body : cm_fun = + match fid with + | A.Replace -> eval_replace_concrete config region_params type_params + | BoxNew -> eval_box_new_concrete config region_params type_params + | BoxDeref -> eval_box_deref_concrete config region_params type_params + | BoxDerefMut -> + eval_box_deref_mut_concrete config region_params type_params + | BoxFree -> + (* Should have been treated above *) raise (Failure "Unreachable") + | VecNew | VecPush | VecInsert | VecLen | VecIndex | VecIndexMut -> + eval_vec_function_concrete config fid region_params type_params + in + + let cc = comp cc cf_eval_body in + + (* Pop the frame *) + let cc = comp cc (pop_frame_assign config dest) in + + (* Continue *) + cc cf + in + (* Compose and apply *) + comp cf_eval_ops cf_eval_call + +(** Instantiate a function signature, introducing fresh abstraction ids and + region ids. This is mostly used in preparation of function calls, when + evaluating in symbolic mode of course. + + Note: there are no region parameters, because they should be erased. + + **Rk.:** this function is **stateful** and generates fresh abstraction ids + for the region groups. + *) +let instantiate_fun_sig (type_params : T.ety list) (sg : A.fun_sig) : + A.inst_fun_sig = + (* Generate fresh abstraction ids and create a substitution from region + * group ids to abstraction ids *) + let rg_abs_ids_bindings = + List.map + (fun rg -> + let abs_id = C.fresh_abstraction_id () in + (rg.T.id, abs_id)) + sg.regions_hierarchy + in + let asubst_map : V.AbstractionId.id T.RegionGroupId.Map.t = + List.fold_left + (fun mp (rg_id, abs_id) -> T.RegionGroupId.Map.add rg_id abs_id mp) + T.RegionGroupId.Map.empty rg_abs_ids_bindings + in + let asubst (rg_id : T.RegionGroupId.id) : V.AbstractionId.id = + T.RegionGroupId.Map.find rg_id asubst_map + in + (* Generate fresh regions and their substitutions *) + let _, rsubst, _ = Subst.fresh_regions_with_substs sg.region_params in + (* Generate the type substitution + * Note that we need the substitution to map the type variables to + * {!rty} types (not {!ety}). In order to do that, we convert the + * type parameters to types with regions. This is possible only + * if those types don't contain any regions. + * This is a current limitation of the analysis: there is still some + * work to do to properly handle full type parametrization. + * *) + let rtype_params = List.map ety_no_regions_to_rty type_params in + let tsubst = + Subst.make_type_subst + (List.map (fun v -> v.T.index) sg.type_params) + rtype_params + in + (* Substitute the signature *) + let inst_sig = Subst.substitute_signature asubst rsubst tsubst sg in + (* Return *) + inst_sig + +(** Helper + + Create abstractions (with no avalues, which have to be inserted afterwards) + from a list of abs region groups. + + [region_can_end]: gives the region groups from which we generate functions + which can end or not. + *) +let create_empty_abstractions_from_abs_region_groups (call_id : V.FunCallId.id) + (kind : V.abs_kind) (rgl : A.abs_region_group list) + (region_can_end : T.RegionGroupId.id -> bool) : V.abs list = + (* We use a reference to progressively create a map from abstraction ids + * to set of ancestor regions. Note that {!abs_to_ancestors_regions} [abs_id] + * returns the union of: + * - the regions of the ancestors of abs_id + * - the regions of abs_id + *) + let abs_to_ancestors_regions : T.RegionId.Set.t V.AbstractionId.Map.t ref = + ref V.AbstractionId.Map.empty + in + (* Auxiliary function to create one abstraction *) + let create_abs (back_id : T.RegionGroupId.id) (rg : A.abs_region_group) : + V.abs = + let abs_id = rg.T.id in + let original_parents = rg.parents in + let parents = + List.fold_left + (fun s pid -> V.AbstractionId.Set.add pid s) + V.AbstractionId.Set.empty rg.parents + in + let regions = + List.fold_left + (fun s rid -> T.RegionId.Set.add rid s) + T.RegionId.Set.empty rg.regions + in + let ancestors_regions = + List.fold_left + (fun acc parent_id -> + T.RegionId.Set.union acc + (V.AbstractionId.Map.find parent_id !abs_to_ancestors_regions)) + T.RegionId.Set.empty rg.parents + in + let ancestors_regions_union_current_regions = + T.RegionId.Set.union ancestors_regions regions + in + let can_end = region_can_end back_id in + abs_to_ancestors_regions := + V.AbstractionId.Map.add abs_id ancestors_regions_union_current_regions + !abs_to_ancestors_regions; + (* Create the abstraction *) + { + V.abs_id; + call_id; + back_id; + kind; + can_end; + parents; + original_parents; + regions; + ancestors_regions; + avalues = []; + } + in + (* Apply *) + T.RegionGroupId.mapi create_abs rgl + +(** Helper. + + Create a list of abstractions from a list of regions groups, and insert + them in the context. + + [region_can_end]: gives the region groups from which we generate functions + which can end or not. + + [compute_abs_avalues]: this function must compute, given an initialized, + empty (i.e., with no avalues) abstraction, compute the avalues which + should be inserted in this abstraction before we insert it in the context. + Note that this function may update the context: it is necessary when + computing borrow projections, for instance. +*) +let create_push_abstractions_from_abs_region_groups (call_id : V.FunCallId.id) + (kind : V.abs_kind) (rgl : A.abs_region_group list) + (region_can_end : T.RegionGroupId.id -> bool) + (compute_abs_avalues : + V.abs -> C.eval_ctx -> C.eval_ctx * V.typed_avalue list) + (ctx : C.eval_ctx) : C.eval_ctx = + (* Initialize the abstractions as empty (i.e., with no avalues) abstractions *) + let empty_absl = + create_empty_abstractions_from_abs_region_groups call_id kind rgl + region_can_end + in + + (* Compute and add the avalues to the abstractions, the insert the abstractions + * in the context. *) + let insert_abs (ctx : C.eval_ctx) (abs : V.abs) : C.eval_ctx = + (* Compute the values to insert in the abstraction *) + let ctx, avalues = compute_abs_avalues abs ctx in + (* Add the avalues to the abstraction *) + let abs = { abs with avalues } in + (* Insert the abstraction in the context *) + let ctx = { ctx with env = Abs abs :: ctx.env } in + (* Return *) + ctx + in + List.fold_left insert_abs ctx empty_absl + +(** Evaluate a statement *) +let rec eval_statement (config : C.config) (st : A.statement) : st_cm_fun = + fun cf ctx -> + (* Debugging *) + log#ldebug + (lazy + ("\n**About to evaluate statement**: [\n" + ^ statement_to_string_with_tab ctx st + ^ "\n]\n\n**Context**:\n" ^ eval_ctx_to_string ctx ^ "\n\n")); + + (* Expand the symbolic values if necessary - we need to do that before + * checking the invariants *) + let cc = greedy_expand_symbolic_values config in + (* Sanity check *) + let cc = comp cc (Inv.cf_check_invariants config) in + + (* Evaluate *) + let cf_eval_st cf : m_fun = + fun ctx -> + match st.content with + | A.Assign (p, rvalue) -> + (* Evaluate the rvalue *) + let cf_eval_rvalue = eval_rvalue config rvalue in + (* Assign *) + let cf_assign cf (res : (V.typed_value, eval_error) result) ctx = + log#ldebug + (lazy + ("about to assign to place: " ^ place_to_string ctx p + ^ "\n- Context:\n" ^ eval_ctx_to_string ctx)); + match res with + | Error EPanic -> cf Panic ctx + | Ok rv -> ( + let expr = assign_to_place config rv p (cf Unit) ctx in + (* Update the synthesized AST - here we store meta-information. + * We do it only in specific cases (it is not always useful, and + * also it can lead to issues - for instance, if we borrow an + * inactivated borrow, we later can't translate it to pure values...) *) + match rvalue with + | E.Use _ + | E.Ref (_, (E.Shared | E.Mut | E.TwoPhaseMut)) + | E.UnaryOp _ | E.BinaryOp _ | E.Discriminant _ | E.Aggregate _ -> + let rp = rvalue_get_place rvalue in + let rp = + match rp with + | Some rp -> Some (S.mk_mplace rp ctx) + | None -> None + in + S.synthesize_assignment (S.mk_mplace p ctx) rv rp expr) + in + + (* Compose and apply *) + comp cf_eval_rvalue cf_assign cf ctx + | A.AssignGlobal { dst; global } -> eval_global config dst global cf ctx + | A.FakeRead p -> + let expand_prim_copy = false in + let cf_prepare cf = + access_rplace_reorganize_and_read config expand_prim_copy Read p cf + in + let cf_continue cf v : m_fun = + fun ctx -> + assert (not (bottom_in_value ctx.ended_regions v)); + cf ctx + in + comp cf_prepare cf_continue (cf Unit) ctx + | A.SetDiscriminant (p, variant_id) -> + set_discriminant config p variant_id cf ctx + | A.Drop p -> drop_value config p (cf Unit) ctx + | A.Assert assertion -> eval_assertion config assertion cf ctx + | A.Call call -> eval_function_call config call cf ctx + | A.Panic -> cf Panic ctx + | A.Return -> cf Return ctx + | A.Break i -> cf (Break i) ctx + | A.Continue i -> cf (Continue i) ctx + | A.Nop -> cf Unit ctx + | A.Sequence (st1, st2) -> + (* Evaluate the first statement *) + let cf_st1 = eval_statement config st1 in + (* Evaluate the sequence *) + let cf_st2 cf res = + match res with + (* Evaluation successful: evaluate the second statement *) + | Unit -> eval_statement config st2 cf + (* Control-flow break: transmit. We enumerate the cases on purpose *) + | Panic | Break _ | Continue _ | Return -> cf res + in + (* Compose and apply *) + comp cf_st1 cf_st2 cf ctx + | A.Loop loop_body -> + (* For now, we don't support loops in symbolic mode *) + assert (config.C.mode = C.ConcreteMode); + (* Continuation for after we evaluate the loop body: depending the result + of doing one loop iteration: + - redoes a loop iteration + - exits the loop + - other... + + We need a specific function because of the {!Continue} case: in case we + continue, we might have to reevaluate the current loop body with the + new context (and repeat this an indefinite number of times). + *) + let rec reeval_loop_body res : m_fun = + match res with + | Return | Panic -> cf res + | Break i -> + (* Break out of the loop by calling the continuation *) + let res = if i = 0 then Unit else Break (i - 1) in + cf res + | Continue 0 -> + (* Re-evaluate the loop body *) + eval_statement config loop_body reeval_loop_body + | Continue i -> + (* Continue to an outer loop *) + cf (Continue (i - 1)) + | Unit -> + (* We can't get there. + * Note that if we decide not to fail here but rather do + * the same thing as for [Continue 0], we could make the + * code slightly simpler: calling {!reeval_loop_body} with + * {!Unit} would account for the first iteration of the loop. + * We prefer to write it this way for consistency and sanity, + * though. *) + raise (Failure "Unreachable") + in + (* Apply *) + eval_statement config loop_body reeval_loop_body ctx + | A.Switch (op, tgts) -> eval_switch config op tgts cf ctx + in + (* Compose and apply *) + comp cc cf_eval_st cf ctx + +and eval_global (config : C.config) (dest : V.VarId.id) + (gid : LA.GlobalDeclId.id) : st_cm_fun = + fun cf ctx -> + let global = C.ctx_lookup_global_decl ctx gid in + let place = { E.var_id = dest; projection = [] } in + match config.mode with + | ConcreteMode -> + (* Treat the evaluation of the global as a call to the global body (without arguments) *) + (eval_local_function_call_concrete config global.body_id [] [] [] place) + cf ctx + | SymbolicMode -> + (* Generate a fresh symbolic value. In the translation, this fresh symbolic value will be + * defined as equal to the value of the global (see {!S.synthesize_global_eval}). *) + let sval = + mk_fresh_symbolic_value V.Global (ety_no_regions_to_rty global.ty) + in + let cc = + assign_to_place config (mk_typed_value_from_symbolic_value sval) place + in + let e = cc (cf Unit) ctx in + S.synthesize_global_eval gid sval e + +(** Evaluate a switch *) +and eval_switch (config : C.config) (op : E.operand) (tgts : A.switch_targets) : + st_cm_fun = + fun cf ctx -> + (* We evaluate the operand in two steps: + * first we prepare it, then we check if its value is concrete or + * symbolic. If it is concrete, we can then evaluate the operand + * directly, otherwise we must first expand the value. + * Note that we can't fully evaluate the operand *then* expand the + * value if it is symbolic, because the value may have been move + * (and would thus floating in thin air...)! + * *) + (* Prepare the operand *) + let cf_eval_op cf : m_fun = eval_operand config op cf in + (* Match on the targets *) + let cf_match (cf : st_m_fun) (op_v : V.typed_value) : m_fun = + fun ctx -> + match tgts with + | A.If (st1, st2) -> ( + match op_v.value with + | V.Concrete (V.Bool b) -> + (* Evaluate the if and the branch body *) + let cf_branch cf : m_fun = + (* Branch *) + if b then eval_statement config st1 cf + else eval_statement config st2 cf + in + (* Compose the continuations *) + cf_branch cf ctx + | V.Symbolic sv -> + (* Expand the symbolic boolean, and continue by evaluating + * the branches *) + let cf_true : m_fun = eval_statement config st1 cf in + let cf_false : m_fun = eval_statement config st2 cf in + expand_symbolic_bool config sv + (S.mk_opt_place_from_op op ctx) + cf_true cf_false ctx + | _ -> raise (Failure "Inconsistent state")) + | A.SwitchInt (int_ty, stgts, otherwise) -> ( + match op_v.value with + | V.Concrete (V.Scalar sv) -> + (* Evaluate the branch *) + let cf_eval_branch cf = + (* Sanity check *) + assert (sv.V.int_ty = int_ty); + (* Find the branch *) + match List.find_opt (fun (svl, _) -> List.mem sv svl) stgts with + | None -> eval_statement config otherwise cf + | Some (_, tgt) -> eval_statement config tgt cf + in + (* Compose *) + cf_eval_branch cf ctx + | V.Symbolic sv -> + (* Expand the symbolic value and continue by evaluating the + * proper branches *) + let stgts = + List.map + (fun (cv, tgt_st) -> (cv, eval_statement config tgt_st cf)) + stgts + in + (* Several branches may be grouped together: every branch is described + * by a pair (list of values, branch expression). + * In order to do a symbolic evaluation, we make this "flat" by + * de-grouping the branches. *) + let stgts = + List.concat + (List.map + (fun (vl, st) -> List.map (fun v -> (v, st)) vl) + stgts) + in + (* Translate the otherwise branch *) + let otherwise = eval_statement config otherwise cf in + (* Expand and continue *) + expand_symbolic_int config sv + (S.mk_opt_place_from_op op ctx) + int_ty stgts otherwise ctx + | _ -> raise (Failure "Inconsistent state")) + in + (* Compose the continuations *) + comp cf_eval_op cf_match cf ctx + +(** Evaluate a function call (auxiliary helper for [eval_statement]) *) +and eval_function_call (config : C.config) (call : A.call) : st_cm_fun = + (* There are two cases: + - this is a local function, in which case we execute its body + - this is a non-local function, in which case there is a special treatment + *) + match call.func with + | A.Regular fid -> + eval_local_function_call config fid call.region_args call.type_args + call.args call.dest + | A.Assumed fid -> + eval_non_local_function_call config fid call.region_args call.type_args + call.args call.dest + +(** Evaluate a local (i.e., non-assumed) function call in concrete mode *) +and eval_local_function_call_concrete (config : C.config) (fid : A.FunDeclId.id) + (region_args : T.erased_region list) (type_args : T.ety list) + (args : E.operand list) (dest : E.place) : st_cm_fun = + fun cf ctx -> + assert (region_args = []); + + (* Retrieve the (correctly instantiated) body *) + let def = C.ctx_lookup_fun_decl ctx fid in + (* We can evaluate the function call only if it is not opaque *) + let body = + match def.body with + | None -> + raise + (Failure + ("Can't evaluate a call to an opaque function: " + ^ Print.name_to_string def.name)) + | Some body -> body + in + let tsubst = + Subst.make_type_subst + (List.map (fun v -> v.T.index) def.A.signature.type_params) + type_args + in + let locals, body_st = Subst.fun_body_substitute_in_body tsubst body in + + (* Evaluate the input operands *) + assert (List.length args = body.A.arg_count); + let cc = eval_operands config args in + + (* Push a frame delimiter - we use {!comp_transmit} to transmit the result + * of the operands evaluation from above to the functions afterwards, while + * ignoring it in this function *) + let cc = comp_transmit cc push_frame in + + (* Compute the initial values for the local variables *) + (* 1. Push the return value *) + let ret_var, locals = + match locals with + | ret_ty :: locals -> (ret_ty, locals) + | _ -> raise (Failure "Unreachable") + in + let input_locals, locals = + Collections.List.split_at locals body.A.arg_count + in + + let cc = comp_transmit cc (push_var ret_var (mk_bottom ret_var.var_ty)) in + + (* 2. Push the input values *) + let cf_push_inputs cf args = + let inputs = List.combine input_locals args in + (* Note that this function checks that the variables and their values + * have the same type (this is important) *) + push_vars inputs cf + in + let cc = comp cc cf_push_inputs in + + (* 3. Push the remaining local variables (initialized as {!Bottom}) *) + let cc = comp cc (push_uninitialized_vars locals) in + + (* Execute the function body *) + let cc = comp cc (eval_function_body config body_st) in + + (* Pop the stack frame and move the return value to its destination *) + let cf_finish cf res = + match res with + | Panic -> cf Panic + | Break _ | Continue _ | Unit -> raise (Failure "Unreachable") + | Return -> + (* Pop the stack frame, retrieve the return value, move it to + * its destination and continue *) + pop_frame_assign config dest (cf Unit) + in + let cc = comp cc cf_finish in + + (* Continue *) + cc cf ctx + +(** Evaluate a local (i.e., non-assumed) function call in symbolic mode *) +and eval_local_function_call_symbolic (config : C.config) (fid : A.FunDeclId.id) + (region_args : T.erased_region list) (type_args : T.ety list) + (args : E.operand list) (dest : E.place) : st_cm_fun = + fun cf ctx -> + (* Retrieve the (correctly instantiated) signature *) + let def = C.ctx_lookup_fun_decl ctx fid in + let sg = def.A.signature in + (* Instantiate the signature and introduce fresh abstraction and region ids + * while doing so *) + let inst_sg = instantiate_fun_sig type_args sg in + (* Sanity check *) + assert (List.length args = List.length def.A.signature.inputs); + (* Evaluate the function call *) + eval_function_call_symbolic_from_inst_sig config (A.Regular fid) inst_sg + region_args type_args args dest cf ctx + +(** Evaluate a function call in symbolic mode by using the function signature. + + This allows us to factorize the evaluation of local and non-local function + calls in symbolic mode: only their signatures matter. + *) +and eval_function_call_symbolic_from_inst_sig (config : C.config) + (fid : A.fun_id) (inst_sg : A.inst_fun_sig) + (region_args : T.erased_region list) (type_args : T.ety list) + (args : E.operand list) (dest : E.place) : st_cm_fun = + fun cf ctx -> + assert (region_args = []); + (* Generate a fresh symbolic value for the return value *) + let ret_sv_ty = inst_sg.A.output in + let ret_spc = mk_fresh_symbolic_value V.FunCallRet ret_sv_ty in + let ret_value = mk_typed_value_from_symbolic_value ret_spc in + let ret_av regions = + mk_aproj_loans_value_from_symbolic_value regions ret_spc + in + let args_places = List.map (fun p -> S.mk_opt_place_from_op p ctx) args in + let dest_place = Some (S.mk_mplace dest ctx) in + + (* Evaluate the input operands *) + let cc = eval_operands config args in + + (* Generate the abstractions and insert them in the context *) + let abs_ids = List.map (fun rg -> rg.T.id) inst_sg.regions_hierarchy in + let cf_call cf (args : V.typed_value list) : m_fun = + fun ctx -> + let args_with_rtypes = List.combine args inst_sg.A.inputs in + + (* Check the type of the input arguments *) + assert ( + List.for_all + (fun ((arg, rty) : V.typed_value * T.rty) -> + arg.V.ty = Subst.erase_regions rty) + args_with_rtypes); + (* Check that the input arguments don't contain symbolic values that can't + * be fed to functions (i.e., symbolic values output from function return + * values and which contain borrows of borrows can't be used as function + * inputs *) + assert ( + List.for_all + (fun arg -> + not (value_has_ret_symbolic_value_with_borrow_under_mut ctx arg)) + args); + + (* Initialize the abstractions and push them in the context. + * First, we define the function which, given an initialized, empty + * abstraction, computes the avalues which should be inserted inside. + *) + let compute_abs_avalues (abs : V.abs) (ctx : C.eval_ctx) : + C.eval_ctx * V.typed_avalue list = + (* Project over the input values *) + let ctx, args_projs = + List.fold_left_map + (fun ctx (arg, arg_rty) -> + apply_proj_borrows_on_input_value config ctx abs.regions + abs.ancestors_regions arg arg_rty) + ctx args_with_rtypes + in + (* Group the input and output values *) + (ctx, List.append args_projs [ ret_av abs.regions ]) + in + (* Actually initialize and insert the abstractions *) + let call_id = C.fresh_fun_call_id () in + let region_can_end _ = true in + let ctx = + create_push_abstractions_from_abs_region_groups call_id V.FunCall + inst_sg.A.regions_hierarchy region_can_end compute_abs_avalues ctx + in + + (* Apply the continuation *) + let expr = cf ctx in + + (* Synthesize the symbolic AST *) + S.synthesize_regular_function_call fid call_id abs_ids type_args args + args_places ret_spc dest_place expr + in + let cc = comp cc cf_call in + + (* Move the return value to its destination *) + let cc = comp cc (assign_to_place config ret_value dest) in + + (* End the abstractions which don't contain loans and don't have parent + * abstractions. + * We do the general, nested borrows case here: we end abstractions, then + * retry (because then we might end their children abstractions) + *) + let abs_ids = ref abs_ids in + let rec end_abs_with_no_loans cf : m_fun = + fun ctx -> + (* Find the abstractions which don't contain loans *) + let no_loans_abs, with_loans_abs = + List.partition + (fun abs_id -> + (* Lookup the abstraction *) + let abs = C.ctx_lookup_abs ctx abs_id in + (* Check if it has parents *) + V.AbstractionId.Set.is_empty abs.parents + (* Check if it contains non-ignored loans *) + && Option.is_none + (InterpreterBorrowsCore + .get_first_non_ignored_aloan_in_abstraction abs)) + !abs_ids + in + (* Check if there are abstractions to end *) + if no_loans_abs <> [] then ( + (* Update the reference to the list of asbtraction ids, for the recursive calls *) + abs_ids := with_loans_abs; + (* End the abstractions which can be ended *) + let no_loans_abs = V.AbstractionId.Set.of_list no_loans_abs in + let cc = InterpreterBorrows.end_abstractions config [] no_loans_abs in + (* Recursive call *) + let cc = comp cc end_abs_with_no_loans in + (* Continue *) + cc cf ctx) + else (* No abstractions to end: continue *) + cf ctx + in + (* Try to end the abstractions with no loans if: + * - the option is enabled + * - the function returns unit + * (see the documentation of {!config} for more information) + *) + let cc = + if config.return_unit_end_abs_with_no_loans && ty_is_unit inst_sg.output + then comp cc end_abs_with_no_loans + else cc + in + + (* Continue - note that we do as if the function call has been successful, + * by giving {!Unit} to the continuation, because we place us in the case + * where we haven't panicked. Of course, the translation needs to take the + * panic case into account... *) + cc (cf Unit) ctx + +(** Evaluate a non-local function call in symbolic mode *) +and eval_non_local_function_call_symbolic (config : C.config) + (fid : A.assumed_fun_id) (region_args : T.erased_region list) + (type_args : T.ety list) (args : E.operand list) (dest : E.place) : + st_cm_fun = + fun cf ctx -> + (* Sanity check: make sure the type parameters don't contain regions - + * this is a current limitation of our synthesis *) + assert ( + List.for_all + (fun ty -> not (ty_has_borrows ctx.type_context.type_infos ty)) + type_args); + + (* There are two cases (and this is extremely annoying): + - the function is not box_free + - the function is box_free + See {!eval_box_free} + *) + match fid with + | A.BoxFree -> + (* Degenerate case: box_free - note that this is not really a function + * call: no need to call a "synthesize_..." function *) + eval_box_free config region_args type_args args dest (cf Unit) ctx + | _ -> + (* "Normal" case: not box_free *) + (* In symbolic mode, the behaviour of a function call is completely defined + * by the signature of the function: we thus simply generate correctly + * instantiated signatures, and delegate the work to an auxiliary function *) + let inst_sig = + match fid with + | A.BoxFree -> + (* should have been treated above *) + raise (Failure "Unreachable") + | _ -> instantiate_fun_sig type_args (Assumed.get_assumed_sig fid) + in + + (* Evaluate the function call *) + eval_function_call_symbolic_from_inst_sig config (A.Assumed fid) inst_sig + region_args type_args args dest cf ctx + +(** Evaluate a non-local (i.e, assumed) function call such as [Box::deref] + (auxiliary helper for [eval_statement]) *) +and eval_non_local_function_call (config : C.config) (fid : A.assumed_fun_id) + (region_args : T.erased_region list) (type_args : T.ety list) + (args : E.operand list) (dest : E.place) : st_cm_fun = + fun cf ctx -> + (* Debug *) + log#ldebug + (lazy + (let type_args = + "[" ^ String.concat ", " (List.map (ety_to_string ctx) type_args) ^ "]" + in + let args = + "[" ^ String.concat ", " (List.map (operand_to_string ctx) args) ^ "]" + in + let dest = place_to_string ctx dest in + "eval_non_local_function_call:\n- fid:" ^ A.show_assumed_fun_id fid + ^ "\n- type_args: " ^ type_args ^ "\n- args: " ^ args ^ "\n- dest: " + ^ dest)); + + match config.mode with + | C.ConcreteMode -> + eval_non_local_function_call_concrete config fid region_args type_args + args dest (cf Unit) ctx + | C.SymbolicMode -> + eval_non_local_function_call_symbolic config fid region_args type_args + args dest cf ctx + +(** Evaluate a local (i.e, not assumed) function call (auxiliary helper for + [eval_statement]) *) +and eval_local_function_call (config : C.config) (fid : A.FunDeclId.id) + (region_args : T.erased_region list) (type_args : T.ety list) + (args : E.operand list) (dest : E.place) : st_cm_fun = + match config.mode with + | ConcreteMode -> + eval_local_function_call_concrete config fid region_args type_args args + dest + | SymbolicMode -> + eval_local_function_call_symbolic config fid region_args type_args args + dest + +(** Evaluate a statement seen as a function body (auxiliary helper for + [eval_statement]) *) +and eval_function_body (config : C.config) (body : A.statement) : st_cm_fun = + fun cf ctx -> + let cc = eval_statement config body in + let cf_finish cf res = + (* Note that we *don't* check the result ({!Panic}, {!Return}, etc.): we + * delegate the check to the caller. *) + (* Expand the symbolic values if necessary - we need to do that before + * checking the invariants *) + let cc = greedy_expand_symbolic_values config in + (* Sanity check *) + let cc = comp_check_ctx cc (Inv.check_invariants config) in + (* Continue *) + cc (cf res) + in + (* Compose and continue *) + comp cc cf_finish cf ctx diff --git a/compiler/InterpreterUtils.ml b/compiler/InterpreterUtils.ml new file mode 100644 index 00000000..e6033e9e --- /dev/null +++ b/compiler/InterpreterUtils.ml @@ -0,0 +1,245 @@ +module T = Types +module V = Values +module E = Expressions +module C = Contexts +module Subst = Substitute +module A = LlbcAst +module L = Logging +open Utils +open TypesUtils +module PA = Print.EvalCtxLlbcAst + +(** Some utilities *) + +let eval_ctx_to_string = Print.Contexts.eval_ctx_to_string +let ety_to_string = PA.ety_to_string +let rty_to_string = PA.rty_to_string +let symbolic_value_to_string = PA.symbolic_value_to_string +let borrow_content_to_string = PA.borrow_content_to_string +let loan_content_to_string = PA.loan_content_to_string +let aborrow_content_to_string = PA.aborrow_content_to_string +let aloan_content_to_string = PA.aloan_content_to_string +let aproj_to_string = PA.aproj_to_string +let typed_value_to_string = PA.typed_value_to_string +let typed_avalue_to_string = PA.typed_avalue_to_string +let place_to_string = PA.place_to_string +let operand_to_string = PA.operand_to_string +let statement_to_string ctx = PA.statement_to_string ctx "" " " +let statement_to_string_with_tab ctx = PA.statement_to_string ctx " " " " + +let same_symbolic_id (sv0 : V.symbolic_value) (sv1 : V.symbolic_value) : bool = + sv0.V.sv_id = sv1.V.sv_id + +let mk_var (index : V.VarId.id) (name : string option) (var_ty : T.ety) : A.var + = + { A.index; name; var_ty } + +(** Small helper - TODO: move *) +let mk_place_from_var_id (var_id : V.VarId.id) : E.place = + { var_id; projection = [] } + +(** Create a fresh symbolic value *) +let mk_fresh_symbolic_value (sv_kind : V.sv_kind) (ty : T.rty) : + V.symbolic_value = + let sv_id = C.fresh_symbolic_value_id () in + let svalue = { V.sv_kind; V.sv_id; V.sv_ty = ty } in + svalue + +(** Create a fresh symbolic value *) +let mk_fresh_symbolic_typed_value (sv_kind : V.sv_kind) (rty : T.rty) : + V.typed_value = + let ty = Subst.erase_regions rty in + (* Generate the fresh a symbolic value *) + let value = mk_fresh_symbolic_value sv_kind rty in + let value = V.Symbolic value in + { V.value; V.ty } + +(** Create a typed value from a symbolic value. *) +let mk_typed_value_from_symbolic_value (svalue : V.symbolic_value) : + V.typed_value = + let av = V.Symbolic svalue in + let av : V.typed_value = + { V.value = av; V.ty = Subst.erase_regions svalue.V.sv_ty } + in + av + +(** Create a loans projector value from a symbolic value. + + Checks if the projector will actually project some regions. If not, + returns {!V.AIgnored} ([_]). + + TODO: update to handle 'static + *) +let mk_aproj_loans_value_from_symbolic_value (regions : T.RegionId.Set.t) + (svalue : V.symbolic_value) : V.typed_avalue = + if ty_has_regions_in_set regions svalue.sv_ty then + let av = V.ASymbolic (V.AProjLoans (svalue, [])) in + let av : V.typed_avalue = { V.value = av; V.ty = svalue.V.sv_ty } in + av + else { V.value = V.AIgnored; ty = svalue.V.sv_ty } + +(** Create a borrows projector from a symbolic value *) +let mk_aproj_borrows_from_symbolic_value (proj_regions : T.RegionId.Set.t) + (svalue : V.symbolic_value) (proj_ty : T.rty) : V.aproj = + if ty_has_regions_in_set proj_regions proj_ty then + V.AProjBorrows (svalue, proj_ty) + else V.AIgnoredProjBorrows + +(** TODO: move *) +let borrow_is_asb (bid : V.BorrowId.id) (asb : V.abstract_shared_borrow) : bool + = + match asb with + | V.AsbBorrow bid' -> bid' = bid + | V.AsbProjReborrows _ -> false + +(** TODO: move *) +let borrow_in_asb (bid : V.BorrowId.id) (asb : V.abstract_shared_borrows) : bool + = + List.exists (borrow_is_asb bid) asb + +(** TODO: move *) +let remove_borrow_from_asb (bid : V.BorrowId.id) + (asb : V.abstract_shared_borrows) : V.abstract_shared_borrows = + let removed = ref 0 in + let asb = + List.filter + (fun asb -> + if not (borrow_is_asb bid asb) then true + else ( + removed := !removed + 1; + false)) + asb + in + assert (!removed = 1); + asb + +(** We sometimes need to return a value whose type may vary depending on + whether we find it in a "concrete" value or an abstraction (ex.: loan + contents when we perform environment lookups by using borrow ids) *) +type ('a, 'b) concrete_or_abs = Concrete of 'a | Abstract of 'b + +(** Generic loan content: concrete or abstract *) +type g_loan_content = (V.loan_content, V.aloan_content) concrete_or_abs + +(** Generic borrow content: concrete or abstract *) +type g_borrow_content = (V.borrow_content, V.aborrow_content) concrete_or_abs + +type abs_or_var_id = AbsId of V.AbstractionId.id | VarId of V.VarId.id option + +(** Utility exception *) +exception FoundBorrowContent of V.borrow_content + +(** Utility exception *) +exception FoundLoanContent of V.loan_content + +(** Utility exception *) +exception FoundABorrowContent of V.aborrow_content + +(** Utility exception *) +exception FoundGBorrowContent of g_borrow_content + +(** Utility exception *) +exception FoundGLoanContent of g_loan_content + +(** Utility exception *) +exception FoundAProjBorrows of V.symbolic_value * T.rty + +let symbolic_value_id_in_ctx (sv_id : V.SymbolicValueId.id) (ctx : C.eval_ctx) : + bool = + let obj = + object + inherit [_] C.iter_eval_ctx as super + + method! visit_Symbolic _ sv = + if sv.V.sv_id = sv_id then raise Found else () + + method! visit_aproj env aproj = + (match aproj with + | AProjLoans (sv, _) | AProjBorrows (sv, _) -> + if sv.V.sv_id = sv_id then raise Found else () + | AEndedProjLoans _ | AEndedProjBorrows _ | AIgnoredProjBorrows -> ()); + super#visit_aproj env aproj + + method! visit_abstract_shared_borrows _ asb = + let visit (asb : V.abstract_shared_borrow) : unit = + match asb with + | V.AsbBorrow _ -> () + | V.AsbProjReborrows (sv, _) -> + if sv.V.sv_id = sv_id then raise Found else () + in + List.iter visit asb + end + in + (* We use exceptions *) + try + obj#visit_eval_ctx () ctx; + false + with Found -> true + +(** Check that a symbolic value doesn't contain ended regions. + + Note that we don't check that the set of ended regions is empty: we + check that the set of ended regions doesn't intersect the set of + regions used in the type (this is more general). +*) +let symbolic_value_has_ended_regions (ended_regions : T.RegionId.Set.t) + (s : V.symbolic_value) : bool = + let regions = rty_regions s.V.sv_ty in + not (T.RegionId.Set.disjoint regions ended_regions) + +(** Check if a {!type:V.value} contains [⊥]. + + Note that this function is very general: it also checks wether + symbolic values contain already ended regions. + *) +let bottom_in_value (ended_regions : T.RegionId.Set.t) (v : V.typed_value) : + bool = + let obj = + object + inherit [_] V.iter_typed_value + method! visit_Bottom _ = raise Found + + method! visit_symbolic_value _ s = + if symbolic_value_has_ended_regions ended_regions s then raise Found + else () + end + in + (* We use exceptions *) + try + obj#visit_typed_value () v; + false + with Found -> true + +let value_has_ret_symbolic_value_with_borrow_under_mut (ctx : C.eval_ctx) + (v : V.typed_value) : bool = + let obj = + object + inherit [_] V.iter_typed_value + + method! visit_symbolic_value _ s = + match s.sv_kind with + | V.FunCallRet -> + if ty_has_borrow_under_mut ctx.type_context.type_infos s.sv_ty then + raise Found + else () + | V.SynthInput | V.SynthInputGivenBack | V.FunCallGivenBack + | V.SynthRetGivenBack -> + () + | V.Global -> () + end + in + (* We use exceptions *) + try + obj#visit_typed_value () v; + false + with Found -> true + +(** Return the place used in an rvalue, if that makes sense. + This is used to compute meta-data, to find pretty names. + *) +let rvalue_get_place (rv : E.rvalue) : E.place option = + match rv with + | Use (Copy p | Move p) -> Some p + | Use (Constant _) -> None + | Ref (p, _) -> Some p + | UnaryOp _ | BinaryOp _ | Discriminant _ | Aggregate _ -> None diff --git a/compiler/Invariants.ml b/compiler/Invariants.ml new file mode 100644 index 00000000..4a3364a6 --- /dev/null +++ b/compiler/Invariants.ml @@ -0,0 +1,794 @@ +(* The following module defines functions to check that some invariants + * are always maintained by evaluation contexts *) + +module T = Types +module V = Values +module E = Expressions +module C = Contexts +module Subst = Substitute +module A = LlbcAst +module L = Logging +open Cps +open TypesUtils +open InterpreterUtils +open InterpreterBorrowsCore + +(** The local logger *) +let log = L.invariants_log + +type borrow_info = { + loan_kind : T.ref_kind; + loan_in_abs : bool; + (* true if the loan was found in an abstraction *) + loan_ids : V.BorrowId.Set.t; + borrow_ids : V.BorrowId.Set.t; +} +[@@deriving show] + +type outer_borrow_info = { + outer_borrow : bool; + (* true if the value is borrowed *) + outer_shared : bool; (* true if the value is borrowed as shared *) +} + +let set_outer_mut (info : outer_borrow_info) : outer_borrow_info = + { info with outer_borrow = true } + +let set_outer_shared (_info : outer_borrow_info) : outer_borrow_info = + { outer_borrow = true; outer_shared = true } + +let ids_reprs_to_string (indent : string) + (reprs : V.BorrowId.id V.BorrowId.Map.t) : string = + V.BorrowId.Map.to_string (Some indent) V.BorrowId.to_string reprs + +let borrows_infos_to_string (indent : string) + (infos : borrow_info V.BorrowId.Map.t) : string = + V.BorrowId.Map.to_string (Some indent) show_borrow_info infos + +type borrow_kind = Mut | Shared | Inactivated + +(** Check that: + - loans and borrows are correctly related + - a two-phase borrow can't point to a value inside an abstraction + *) +let check_loans_borrows_relation_invariant (ctx : C.eval_ctx) : unit = + (* Link all the borrow ids to a representant - necessary because of shared + * borrows/loans *) + let ids_reprs : V.BorrowId.id V.BorrowId.Map.t ref = + ref V.BorrowId.Map.empty + in + (* Link all the id representants to a borrow information *) + let borrows_infos : borrow_info V.BorrowId.Map.t ref = + ref V.BorrowId.Map.empty + in + let context_to_string () : string = + eval_ctx_to_string ctx ^ "- representants:\n" + ^ ids_reprs_to_string " " !ids_reprs + ^ "\n- info:\n" + ^ borrows_infos_to_string " " !borrows_infos + in + (* Ignored loans - when we find an ignored loan while building the borrows_infos + * map, we register it in this list; once the borrows_infos map is completely + * built, we check that all the borrow ids of the ignored loans are in this + * map *) + let ignored_loans : (T.ref_kind * V.BorrowId.id) list ref = ref [] in + + (* first, register all the loans *) + (* Some utilities to register the loans *) + let register_ignored_loan (rkind : T.ref_kind) (bid : V.BorrowId.id) : unit = + ignored_loans := (rkind, bid) :: !ignored_loans + in + + let register_shared_loan (loan_in_abs : bool) (bids : V.BorrowId.Set.t) : unit + = + let reprs = !ids_reprs in + let infos = !borrows_infos in + (* Use the first borrow id as representant *) + let repr_bid = V.BorrowId.Set.min_elt bids in + assert (not (V.BorrowId.Map.mem repr_bid infos)); + (* Insert the mappings to the representant *) + let reprs = + V.BorrowId.Set.fold + (fun bid reprs -> + assert (not (V.BorrowId.Map.mem bid reprs)); + V.BorrowId.Map.add bid repr_bid reprs) + bids reprs + in + (* Insert the loan info *) + let info = + { + loan_kind = T.Shared; + loan_in_abs; + loan_ids = bids; + borrow_ids = V.BorrowId.Set.empty; + } + in + let infos = V.BorrowId.Map.add repr_bid info infos in + (* Update *) + ids_reprs := reprs; + borrows_infos := infos + in + + let register_mut_loan (loan_in_abs : bool) (bid : V.BorrowId.id) : unit = + let reprs = !ids_reprs in + let infos = !borrows_infos in + (* Sanity checks *) + assert (not (V.BorrowId.Map.mem bid reprs)); + assert (not (V.BorrowId.Map.mem bid infos)); + (* Add the mapping for the representant *) + let reprs = V.BorrowId.Map.add bid bid reprs in + (* Add the mapping for the loan info *) + let info = + { + loan_kind = T.Mut; + loan_in_abs; + loan_ids = V.BorrowId.Set.singleton bid; + borrow_ids = V.BorrowId.Set.empty; + } + in + let infos = V.BorrowId.Map.add bid info infos in + (* Update *) + ids_reprs := reprs; + borrows_infos := infos + in + + let loans_visitor = + object + inherit [_] C.iter_eval_ctx as super + + method! visit_Var _ binder v = + let inside_abs = false in + super#visit_Var inside_abs binder v + + method! visit_Abs _ abs = + let inside_abs = true in + super#visit_Abs inside_abs abs + + method! visit_loan_content inside_abs lc = + (* Register the loan *) + let _ = + match lc with + | V.SharedLoan (bids, _) -> register_shared_loan inside_abs bids + | V.MutLoan bid -> register_mut_loan inside_abs bid + in + (* Continue exploring *) + super#visit_loan_content inside_abs lc + + method! visit_aloan_content inside_abs lc = + let _ = + match lc with + | V.AMutLoan (bid, _) -> register_mut_loan inside_abs bid + | V.ASharedLoan (bids, _, _) -> register_shared_loan inside_abs bids + | V.AIgnoredMutLoan (bid, _) -> register_ignored_loan T.Mut bid + | V.AIgnoredSharedLoan _ + | V.AEndedMutLoan { given_back = _; child = _; given_back_meta = _ } + | V.AEndedSharedLoan (_, _) + | V.AEndedIgnoredMutLoan + { given_back = _; child = _; given_back_meta = _ } -> + (* Do nothing *) + () + in + (* Continue exploring *) + super#visit_aloan_content inside_abs lc + end + in + + (* Visit *) + let inside_abs = false in + loans_visitor#visit_eval_ctx inside_abs ctx; + + (* Then, register all the borrows *) + (* Some utilities to register the borrows *) + let find_info (bid : V.BorrowId.id) : borrow_info = + (* Find the representant *) + match V.BorrowId.Map.find_opt bid !ids_reprs with + | Some repr_bid -> + (* Lookup the info *) + V.BorrowId.Map.find repr_bid !borrows_infos + | None -> + let err = + "find_info: could not find the representant of borrow " + ^ V.BorrowId.to_string bid ^ ":\nContext:\n" ^ context_to_string () + in + log#serror err; + failwith err + in + + let update_info (bid : V.BorrowId.id) (info : borrow_info) : unit = + (* Find the representant *) + let repr_bid = V.BorrowId.Map.find bid !ids_reprs in + (* Update the info *) + let infos = + V.BorrowId.Map.update repr_bid + (fun x -> + match x with Some _ -> Some info | None -> failwith "Unreachable") + !borrows_infos + in + borrows_infos := infos + in + + let register_ignored_borrow = register_ignored_loan in + + let register_borrow (kind : borrow_kind) (bid : V.BorrowId.id) : unit = + (* Lookup the info *) + let info = find_info bid in + (* Check that the borrow kind is consistent *) + (match (info.loan_kind, kind) with + | T.Shared, (Shared | Inactivated) | T.Mut, Mut -> () + | _ -> failwith "Invariant not satisfied"); + (* An inactivated borrow can't point to a value inside an abstraction *) + assert (kind <> Inactivated || not info.loan_in_abs); + (* Insert the borrow id *) + let borrow_ids = info.borrow_ids in + assert (not (V.BorrowId.Set.mem bid borrow_ids)); + let info = { info with borrow_ids = V.BorrowId.Set.add bid borrow_ids } in + (* Update the info in the map *) + update_info bid info + in + + let borrows_visitor = + object + inherit [_] C.iter_eval_ctx as super + + method! visit_abstract_shared_borrows _ asb = + let visit asb = + match asb with + | V.AsbBorrow bid -> register_borrow Shared bid + | V.AsbProjReborrows _ -> () + in + List.iter visit asb + + method! visit_borrow_content env bc = + (* Register the loan *) + let _ = + match bc with + | V.SharedBorrow (_, bid) -> register_borrow Shared bid + | V.MutBorrow (bid, _) -> register_borrow Mut bid + | V.InactivatedMutBorrow (_, bid) -> register_borrow Inactivated bid + in + (* Continue exploring *) + super#visit_borrow_content env bc + + method! visit_aborrow_content env bc = + let _ = + match bc with + | V.AMutBorrow (_, bid, _) -> register_borrow Mut bid + | V.ASharedBorrow bid -> register_borrow Shared bid + | V.AIgnoredMutBorrow (Some bid, _) -> register_ignored_borrow Mut bid + | V.AIgnoredMutBorrow (None, _) + | V.AEndedMutBorrow _ | V.AEndedIgnoredMutBorrow _ + | V.AEndedSharedBorrow | V.AProjSharedBorrow _ -> + (* Do nothing *) + () + in + (* Continue exploring *) + super#visit_aborrow_content env bc + end + in + + (* Visit *) + borrows_visitor#visit_eval_ctx () ctx; + + (* Debugging *) + log#ldebug + (lazy ("\nAbout to check context invariant:\n" ^ context_to_string ())); + + (* Finally, check that everything is consistant *) + (* First, check all the ignored loans are present at the proper place *) + List.iter + (fun (rkind, bid) -> + let info = find_info bid in + assert (info.loan_kind = rkind)) + !ignored_loans; + + (* Then, check the borrow infos *) + V.BorrowId.Map.iter + (fun _ info -> + (* Note that we can't directly compare the sets - I guess they are + * different depending on the order in which we add the elements... *) + assert ( + V.BorrowId.Set.elements info.loan_ids + = V.BorrowId.Set.elements info.borrow_ids); + match info.loan_kind with + | T.Mut -> assert (V.BorrowId.Set.cardinal info.loan_ids = 1) + | T.Shared -> ()) + !borrows_infos + +(** Check that: + - borrows/loans can't contain ⊥ or inactivated mut borrows + - shared loans can't contain mutable loans + *) +let check_borrowed_values_invariant (config : C.config) (ctx : C.eval_ctx) : + unit = + let visitor = + object + inherit [_] C.iter_eval_ctx as super + + method! visit_Bottom info = + (* No ⊥ inside borrowed values *) + assert (config.C.allow_bottom_below_borrow || not info.outer_borrow) + + method! visit_ABottom _info = + (* ⊥ inside an abstraction is not the same as in a regular value *) + () + + method! visit_loan_content info lc = + (* Update the info *) + let info = + match lc with + | V.SharedLoan (_, _) -> set_outer_shared info + | V.MutLoan _ -> + (* No mutable loan inside a shared loan *) + assert (not info.outer_shared); + set_outer_mut info + in + (* Continue exploring *) + super#visit_loan_content info lc + + method! visit_borrow_content info bc = + (* Update the info *) + let info = + match bc with + | V.SharedBorrow _ -> set_outer_shared info + | V.InactivatedMutBorrow _ -> + assert (not info.outer_borrow); + set_outer_shared info + | V.MutBorrow (_, _) -> set_outer_mut info + in + (* Continue exploring *) + super#visit_borrow_content info bc + + method! visit_aloan_content info lc = + (* Update the info *) + let info = + match lc with + | V.AMutLoan (_, _) -> set_outer_mut info + | V.ASharedLoan (_, _, _) -> set_outer_shared info + | V.AEndedMutLoan { given_back = _; child = _; given_back_meta = _ } + -> + set_outer_mut info + | V.AEndedSharedLoan (_, _) -> set_outer_shared info + | V.AIgnoredMutLoan (_, _) -> set_outer_mut info + | V.AEndedIgnoredMutLoan + { given_back = _; child = _; given_back_meta = _ } -> + set_outer_mut info + | V.AIgnoredSharedLoan _ -> set_outer_shared info + in + (* Continue exploring *) + super#visit_aloan_content info lc + + method! visit_aborrow_content info bc = + (* Update the info *) + let info = + match bc with + | V.AMutBorrow (_, _, _) -> set_outer_mut info + | V.ASharedBorrow _ | V.AEndedSharedBorrow -> set_outer_shared info + | V.AIgnoredMutBorrow _ | V.AEndedMutBorrow _ + | V.AEndedIgnoredMutBorrow _ -> + set_outer_mut info + | V.AProjSharedBorrow _ -> set_outer_shared info + in + (* Continue exploring *) + super#visit_aborrow_content info bc + end + in + + (* Explore *) + let info = { outer_borrow = false; outer_shared = false } in + visitor#visit_eval_ctx info ctx + +let check_constant_value_type (cv : V.constant_value) (ty : T.ety) : unit = + match (cv, ty) with + | V.Scalar sv, T.Integer int_ty -> assert (sv.int_ty = int_ty) + | V.Bool _, T.Bool | V.Char _, T.Char | V.String _, T.Str -> () + | _ -> failwith "Erroneous typing" + +let check_typing_invariant (ctx : C.eval_ctx) : unit = + (* TODO: the type of aloans doens't make sense: they have a type + * of the shape [& (mut) T] where they should have type [T]... + * This messes a bit the type invariant checks when checking the + * children. In order to isolate the problem (for future modifications) + * we introduce function, so that we can easily spot all the involved + * places. + * *) + let aloan_get_expected_child_type (ty : 'r T.ty) : 'r T.ty = + let _, ty, _ = ty_get_ref ty in + ty + in + + let visitor = + object + inherit [_] C.iter_eval_ctx as super + method! visit_abs _ abs = super#visit_abs (Some abs) abs + + method! visit_typed_value info tv = + (* Check the current pair (value, type) *) + (match (tv.V.value, tv.V.ty) with + | V.Concrete cv, ty -> check_constant_value_type cv ty + (* ADT case *) + | V.Adt av, T.Adt (T.AdtId def_id, regions, tys) -> + (* Retrieve the definition to check the variant id, the number of + * parameters, etc. *) + let def = C.ctx_lookup_type_decl ctx def_id in + (* Check the number of parameters *) + assert (List.length regions = List.length def.region_params); + assert (List.length tys = List.length def.type_params); + (* Check that the variant id is consistent *) + (match (av.V.variant_id, def.T.kind) with + | Some variant_id, T.Enum variants -> + assert (T.VariantId.to_int variant_id < List.length variants) + | None, T.Struct _ -> () + | _ -> failwith "Erroneous typing"); + (* Check that the field types are correct *) + let field_types = + Subst.type_decl_get_instantiated_field_etypes def av.V.variant_id + tys + in + let fields_with_types = + List.combine av.V.field_values field_types + in + List.iter + (fun ((v, ty) : V.typed_value * T.ety) -> assert (v.V.ty = ty)) + fields_with_types + (* Tuple case *) + | V.Adt av, T.Adt (T.Tuple, regions, tys) -> + assert (regions = []); + assert (av.V.variant_id = None); + (* Check that the fields have the proper values - and check that there + * are as many fields as field types at the same time *) + let fields_with_types = List.combine av.V.field_values tys in + List.iter + (fun ((v, ty) : V.typed_value * T.ety) -> assert (v.V.ty = ty)) + fields_with_types + (* Assumed type case *) + | V.Adt av, T.Adt (T.Assumed aty_id, regions, tys) -> ( + assert (av.V.variant_id = None || aty_id = T.Option); + match (aty_id, av.V.field_values, regions, tys) with + (* Box *) + | T.Box, [ inner_value ], [], [ inner_ty ] + | T.Option, [ inner_value ], [], [ inner_ty ] -> + assert (inner_value.V.ty = inner_ty) + | T.Option, _, [], [ _ ] -> + (* Option::None: nothing to check *) + () + | T.Vec, fvs, [], [ vec_ty ] -> + List.iter + (fun (v : V.typed_value) -> assert (v.ty = vec_ty)) + fvs + | _ -> failwith "Erroneous type") + | V.Bottom, _ -> (* Nothing to check *) () + | V.Borrow bc, T.Ref (_, ref_ty, rkind) -> ( + match (bc, rkind) with + | V.SharedBorrow (_, bid), T.Shared + | V.InactivatedMutBorrow (_, bid), T.Mut -> ( + (* Lookup the borrowed value to check it has the proper type *) + let _, glc = lookup_loan ek_all bid ctx in + match glc with + | Concrete (V.SharedLoan (_, sv)) + | Abstract (V.ASharedLoan (_, sv, _)) -> + assert (sv.V.ty = ref_ty) + | _ -> failwith "Inconsistent context") + | V.MutBorrow (_, bv), T.Mut -> + assert ( + (* Check that the borrowed value has the proper type *) + bv.V.ty = ref_ty) + | _ -> failwith "Erroneous typing") + | V.Loan lc, ty -> ( + match lc with + | V.SharedLoan (_, sv) -> assert (sv.V.ty = ty) + | V.MutLoan bid -> ( + (* Lookup the borrowed value to check it has the proper type *) + let glc = lookup_borrow ek_all bid ctx in + match glc with + | Concrete (V.MutBorrow (_, bv)) -> assert (bv.V.ty = ty) + | Abstract (V.AMutBorrow (_, _, sv)) -> + assert (Subst.erase_regions sv.V.ty = ty) + | _ -> failwith "Inconsistent context")) + | V.Symbolic sv, ty -> + let ty' = Subst.erase_regions sv.V.sv_ty in + assert (ty' = ty) + | _ -> failwith "Erroneous typing"); + (* Continue exploring to inspect the subterms *) + super#visit_typed_value info tv + + (* TODO: there is a lot of duplication with {!visit_typed_value} + * which is quite annoying. There might be a way of factorizing + * that by factorizing the definitions of value and avalue, but + * the generation of visitors then doesn't work properly (TODO: + * report that). Still, it is actually not that problematic + * because this code shouldn't change a lot in the future, + * so the cost of maintenance should be pretty low. + * *) + method! visit_typed_avalue info atv = + (* Check the current pair (value, type) *) + (match (atv.V.value, atv.V.ty) with + | V.AConcrete cv, ty -> + check_constant_value_type cv (Subst.erase_regions ty) + (* ADT case *) + | V.AAdt av, T.Adt (T.AdtId def_id, regions, tys) -> + (* Retrieve the definition to check the variant id, the number of + * parameters, etc. *) + let def = C.ctx_lookup_type_decl ctx def_id in + (* Check the number of parameters *) + assert (List.length regions = List.length def.region_params); + assert (List.length tys = List.length def.type_params); + (* Check that the variant id is consistent *) + (match (av.V.variant_id, def.T.kind) with + | Some variant_id, T.Enum variants -> + assert (T.VariantId.to_int variant_id < List.length variants) + | None, T.Struct _ -> () + | _ -> failwith "Erroneous typing"); + (* Check that the field types are correct *) + let field_types = + Subst.type_decl_get_instantiated_field_rtypes def av.V.variant_id + regions tys + in + let fields_with_types = + List.combine av.V.field_values field_types + in + List.iter + (fun ((v, ty) : V.typed_avalue * T.rty) -> assert (v.V.ty = ty)) + fields_with_types + (* Tuple case *) + | V.AAdt av, T.Adt (T.Tuple, regions, tys) -> + assert (regions = []); + assert (av.V.variant_id = None); + (* Check that the fields have the proper values - and check that there + * are as many fields as field types at the same time *) + let fields_with_types = List.combine av.V.field_values tys in + List.iter + (fun ((v, ty) : V.typed_avalue * T.rty) -> assert (v.V.ty = ty)) + fields_with_types + (* Assumed type case *) + | V.AAdt av, T.Adt (T.Assumed aty_id, regions, tys) -> ( + assert (av.V.variant_id = None); + match (aty_id, av.V.field_values, regions, tys) with + (* Box *) + | T.Box, [ boxed_value ], [], [ boxed_ty ] -> + assert (boxed_value.V.ty = boxed_ty) + | _ -> failwith "Erroneous type") + | V.ABottom, _ -> (* Nothing to check *) () + | V.ABorrow bc, T.Ref (_, ref_ty, rkind) -> ( + match (bc, rkind) with + | V.AMutBorrow (_, _, av), T.Mut -> + (* Check that the child value has the proper type *) + assert (av.V.ty = ref_ty) + | V.ASharedBorrow bid, T.Shared -> ( + (* Lookup the borrowed value to check it has the proper type *) + let _, glc = lookup_loan ek_all bid ctx in + match glc with + | Concrete (V.SharedLoan (_, sv)) + | Abstract (V.ASharedLoan (_, sv, _)) -> + assert (sv.V.ty = Subst.erase_regions ref_ty) + | _ -> failwith "Inconsistent context") + | V.AIgnoredMutBorrow (_opt_bid, av), T.Mut -> + assert (av.V.ty = ref_ty) + | ( V.AEndedIgnoredMutBorrow + { given_back_loans_proj; child; given_back_meta = _ }, + T.Mut ) -> + assert (given_back_loans_proj.V.ty = ref_ty); + assert (child.V.ty = ref_ty) + | V.AProjSharedBorrow _, T.Shared -> () + | _ -> failwith "Inconsistent context") + | V.ALoan lc, aty -> ( + match lc with + | V.AMutLoan (bid, child_av) | V.AIgnoredMutLoan (bid, child_av) + -> ( + let borrowed_aty = aloan_get_expected_child_type aty in + assert (child_av.V.ty = borrowed_aty); + (* Lookup the borrowed value to check it has the proper type *) + let glc = lookup_borrow ek_all bid ctx in + match glc with + | Concrete (V.MutBorrow (_, bv)) -> + assert (bv.V.ty = Subst.erase_regions borrowed_aty) + | Abstract (V.AMutBorrow (_, _, sv)) -> + assert ( + Subst.erase_regions sv.V.ty + = Subst.erase_regions borrowed_aty) + | _ -> failwith "Inconsistent context") + | V.ASharedLoan (_, sv, child_av) | V.AEndedSharedLoan (sv, child_av) + -> + let borrowed_aty = aloan_get_expected_child_type aty in + assert (sv.V.ty = Subst.erase_regions borrowed_aty); + (* TODO: the type of aloans doesn't make sense, see above *) + assert (child_av.V.ty = borrowed_aty) + | V.AEndedMutLoan { given_back; child; given_back_meta = _ } + | V.AEndedIgnoredMutLoan { given_back; child; given_back_meta = _ } + -> + let borrowed_aty = aloan_get_expected_child_type aty in + assert (given_back.V.ty = borrowed_aty); + assert (child.V.ty = borrowed_aty) + | V.AIgnoredSharedLoan child_av -> + assert (child_av.V.ty = aloan_get_expected_child_type aty)) + | V.ASymbolic aproj, ty -> ( + let ty1 = Subst.erase_regions ty in + match aproj with + | V.AProjLoans (sv, _) -> + let ty2 = Subst.erase_regions sv.V.sv_ty in + assert (ty1 = ty2); + (* Also check that the symbolic values contain regions of interest - + * otherwise they should have been reduced to [_] *) + let abs = Option.get info in + assert (ty_has_regions_in_set abs.regions sv.V.sv_ty) + | V.AProjBorrows (sv, proj_ty) -> + let ty2 = Subst.erase_regions sv.V.sv_ty in + assert (ty1 = ty2); + (* Also check that the symbolic values contain regions of interest - + * otherwise they should have been reduced to [_] *) + let abs = Option.get info in + assert (ty_has_regions_in_set abs.regions proj_ty) + | V.AEndedProjLoans (_msv, given_back_ls) -> + List.iter + (fun (_, proj) -> + match proj with + | V.AProjBorrows (_sv, ty') -> assert (ty' = ty) + | V.AEndedProjBorrows _ | V.AIgnoredProjBorrows -> () + | _ -> failwith "Unexpected") + given_back_ls + | V.AEndedProjBorrows _ | V.AIgnoredProjBorrows -> ()) + | V.AIgnored, _ -> () + | _ -> failwith "Erroneous typing"); + (* Continue exploring to inspect the subterms *) + super#visit_typed_avalue info atv + end + in + visitor#visit_eval_ctx (None : V.abs option) ctx + +type proj_borrows_info = { + abs_id : V.AbstractionId.id; + regions : T.RegionId.Set.t; + proj_ty : T.rty; + as_shared_value : bool; (** True if the value is below a shared borrow *) +} +[@@deriving show] + +type proj_loans_info = { + abs_id : V.AbstractionId.id; + regions : T.RegionId.Set.t; +} +[@@deriving show] + +type sv_info = { + ty : T.rty; + env_count : int; + aproj_borrows : proj_borrows_info list; + aproj_loans : proj_loans_info list; +} +[@@deriving show] + +(** Check the invariants over the symbolic values. + + - a symbolic value can't be both in proj_borrows and in the concrete env + (this is why we preemptively expand copyable symbolic values) + - if a symbolic value contains regions: there is at most one occurrence + of this value in the concrete env + - if there is an aproj_borrows in the environment, there must also be a + corresponding aproj_loans + - aproj_loans are mutually disjoint + - TODO: aproj_borrows are mutually disjoint + - the union of the aproj_loans contains the aproj_borrows applied on the + same symbolic values + *) +let check_symbolic_values (_config : C.config) (ctx : C.eval_ctx) : unit = + (* Small utility *) + let module M = V.SymbolicValueId.Map in + let infos : sv_info M.t ref = ref M.empty in + let lookup_info (sv : V.symbolic_value) : sv_info = + match M.find_opt sv.V.sv_id !infos with + | Some info -> info + | None -> + { ty = sv.sv_ty; env_count = 0; aproj_borrows = []; aproj_loans = [] } + in + let update_info (sv : V.symbolic_value) (info : sv_info) = + infos := M.add sv.sv_id info !infos + in + let add_env_sv (sv : V.symbolic_value) : unit = + let info = lookup_info sv in + let info = { info with env_count = info.env_count + 1 } in + update_info sv info + in + let add_aproj_borrows (sv : V.symbolic_value) abs_id regions proj_ty + as_shared_value : unit = + let info = lookup_info sv in + let binfo = { abs_id; regions; proj_ty; as_shared_value } in + let info = { info with aproj_borrows = binfo :: info.aproj_borrows } in + update_info sv info + in + let add_aproj_loans (sv : V.symbolic_value) abs_id regions : unit = + let info = lookup_info sv in + let linfo = { abs_id; regions } in + let info = { info with aproj_loans = linfo :: info.aproj_loans } in + update_info sv info + in + (* Visitor *) + let obj = + object + inherit [_] C.iter_eval_ctx as super + method! visit_abs _ abs = super#visit_abs (Some abs) abs + method! visit_Symbolic _ sv = add_env_sv sv + + method! visit_abstract_shared_borrows abs asb = + let abs = Option.get abs in + let visit asb = + match asb with + | V.AsbBorrow _ -> () + | AsbProjReborrows (sv, proj_ty) -> + add_aproj_borrows sv abs.abs_id abs.regions proj_ty true + in + List.iter visit asb + + method! visit_aproj abs aproj = + (let abs = Option.get abs in + match aproj with + | AProjLoans (sv, _) -> add_aproj_loans sv abs.abs_id abs.regions + | AProjBorrows (sv, proj_ty) -> + add_aproj_borrows sv abs.abs_id abs.regions proj_ty false + | AEndedProjLoans _ | AEndedProjBorrows _ | AIgnoredProjBorrows -> ()); + super#visit_aproj abs aproj + end + in + (* Collect the information *) + obj#visit_eval_ctx None ctx; + log#ldebug + (lazy + ("check_symbolic_values: collected information:\n" + ^ V.SymbolicValueId.Map.to_string (Some " ") show_sv_info !infos)); + (* Check *) + let check_info _id info = + (* TODO: check that: + * - the borrows are mutually disjoint + *) + (* A symbolic value can't be both in the regular environment and inside + * projectors of borrows in abstractions *) + assert (info.env_count = 0 || info.aproj_borrows = []); + (* A symbolic value containing borrows can't be duplicated (i.e., copied): + * it must be expanded first *) + if ty_has_borrows ctx.type_context.type_infos info.ty then + assert (info.env_count <= 1); + (* A duplicated symbolic value is necessarily primitively copyable *) + assert (info.env_count <= 1 || ty_is_primitively_copyable info.ty); + + assert (info.aproj_borrows = [] || info.aproj_loans <> []); + (* At the same time: + * - check that the loans don't intersect + * - compute the set of regions for which we project loans + *) + (* Check that the loan projectors contain the region projectors *) + let loan_regions = + List.fold_left + (fun regions linfo -> + let regions = + T.RegionId.Set.fold + (fun rid regions -> + assert (not (T.RegionId.Set.mem rid regions)); + T.RegionId.Set.add rid regions) + regions linfo.regions + in + regions) + T.RegionId.Set.empty info.aproj_loans + in + (* Check that the union of the loan projectors contains the borrow projections. *) + List.iter + (fun binfo -> + assert ( + projection_contains info.ty loan_regions binfo.proj_ty binfo.regions)) + info.aproj_borrows; + () + in + + M.iter check_info !infos + +let check_invariants (config : C.config) (ctx : C.eval_ctx) : unit = + if config.C.check_invariants then ( + log#ldebug (lazy "Checking invariants"); + check_loans_borrows_relation_invariant ctx; + check_borrowed_values_invariant config ctx; + check_typing_invariant ctx; + check_symbolic_values config ctx) + else log#ldebug (lazy "Not checking invariants (check is not activated)") + +(** Same as {!check_invariants}, but written in CPS *) +let cf_check_invariants (config : C.config) : cm_fun = + fun cf ctx -> + check_invariants config ctx; + cf ctx diff --git a/compiler/LlbcAst.ml b/compiler/LlbcAst.ml new file mode 100644 index 00000000..1b08f1ea --- /dev/null +++ b/compiler/LlbcAst.ml @@ -0,0 +1,205 @@ +open Names +open Types +open Values +open Expressions +open Identifiers +module FunDeclId = IdGen () +module GlobalDeclId = IdGen () +open Meta + +(** A variable, as used in a function definition *) +type var = { + index : VarId.id; (** Unique variable identifier *) + name : string option; + var_ty : ety; + (** The variable type - erased type, because variables are not used + ** in function signatures: they are only used to declare the list of + ** variables manipulated by a function body *) +} +[@@deriving show] + +type assumed_fun_id = + | Replace (** [core::mem::replace] *) + | BoxNew + | BoxDeref (** [core::ops::deref::Deref::>::deref] *) + | BoxDerefMut + (** [core::ops::deref::DerefMut::>::deref_mut] *) + | BoxFree + | VecNew + | VecPush + | VecInsert + | VecLen + | VecIndex (** [core::ops::index::Index::index, usize>] *) + | VecIndexMut + (** [core::ops::index::IndexMut::index_mut, usize>] *) +[@@deriving show, ord] + +type fun_id = Regular of FunDeclId.id | Assumed of assumed_fun_id +[@@deriving show, ord] + +type global_assignment = { dst : VarId.id; global : GlobalDeclId.id } +[@@deriving show] + +type assertion = { cond : operand; expected : bool } [@@deriving show] + +type abs_region_group = (AbstractionId.id, RegionId.id) g_region_group +[@@deriving show] + +type abs_region_groups = (AbstractionId.id, RegionId.id) g_region_groups +[@@deriving show] + +(** A function signature, as used when declaring functions *) +type fun_sig = { + region_params : region_var list; + num_early_bound_regions : int; + regions_hierarchy : region_var_groups; + type_params : type_var list; + inputs : sty list; + output : sty; +} +[@@deriving show] + +(** A function signature, after instantiation *) +type inst_fun_sig = { + regions_hierarchy : abs_region_groups; + inputs : rty list; + output : rty; +} +[@@deriving show] + +type call = { + func : fun_id; + region_args : erased_region list; + type_args : ety list; + args : operand list; + dest : place; +} +[@@deriving show] + +(** Ancestor for [typed_value] iter visitor *) +class ['self] iter_statement_base = + object (_self : 'self) + inherit [_] VisitorsRuntime.iter + + method visit_global_assignment : 'env -> global_assignment -> unit = + fun _ _ -> () + + method visit_meta : 'env -> meta -> unit = fun _ _ -> () + method visit_place : 'env -> place -> unit = fun _ _ -> () + method visit_rvalue : 'env -> rvalue -> unit = fun _ _ -> () + method visit_id : 'env -> VariantId.id -> unit = fun _ _ -> () + method visit_assertion : 'env -> assertion -> unit = fun _ _ -> () + method visit_operand : 'env -> operand -> unit = fun _ _ -> () + method visit_call : 'env -> call -> unit = fun _ _ -> () + method visit_integer_type : 'env -> integer_type -> unit = fun _ _ -> () + method visit_scalar_value : 'env -> scalar_value -> unit = fun _ _ -> () + end + +(** Ancestor for [typed_value] map visitor *) +class ['self] map_statement_base = + object (_self : 'self) + inherit [_] VisitorsRuntime.map + + method visit_global_assignment + : 'env -> global_assignment -> global_assignment = + fun _ x -> x + + method visit_meta : 'env -> meta -> meta = fun _ x -> x + method visit_place : 'env -> place -> place = fun _ x -> x + method visit_rvalue : 'env -> rvalue -> rvalue = fun _ x -> x + method visit_id : 'env -> VariantId.id -> VariantId.id = fun _ x -> x + method visit_assertion : 'env -> assertion -> assertion = fun _ x -> x + method visit_operand : 'env -> operand -> operand = fun _ x -> x + method visit_call : 'env -> call -> call = fun _ x -> x + + method visit_integer_type : 'env -> integer_type -> integer_type = + fun _ x -> x + + method visit_scalar_value : 'env -> scalar_value -> scalar_value = + fun _ x -> x + end + +type statement = { + meta : meta; (** The statement meta-data *) + content : raw_statement; (** The statement itself *) +} + +and raw_statement = + | Assign of place * rvalue + | AssignGlobal of global_assignment + | FakeRead of place + | SetDiscriminant of place * VariantId.id + | Drop of place + | Assert of assertion + | Call of call + | Panic + | Return + | Break of int + (** Break to (outer) loop. The [int] identifies the loop to break to: + * 0: break to the first outer loop (the current loop) + * 1: break to the second outer loop + * ... + *) + | Continue of int + (** Continue to (outer) loop. The loop identifier works + the same way as for {!Break} *) + | Nop + | Sequence of statement * statement + | Switch of operand * switch_targets + | Loop of statement + +and switch_targets = + | If of statement * statement (** Gives the "if" and "else" blocks *) + | SwitchInt of integer_type * (scalar_value list * statement) list * statement + (** The targets for a switch over an integer are: + - the list [(matched values, statement to execute)] + We need a list for the matched values in case we do something like this: + [switch n { 0 | 1 => ..., _ => ... }] + - the "otherwise" statement + Also note that we precise the type of the integer (uint32, int64, etc.) + which we switch on. *) +[@@deriving + show, + visitors + { + name = "iter_statement"; + variety = "iter"; + ancestors = [ "iter_statement_base" ]; + nude = true (* Don't inherit {!VisitorsRuntime.iter} *); + concrete = true; + }, + visitors + { + name = "map_statement"; + variety = "map"; + ancestors = [ "map_statement_base" ]; + nude = true (* Don't inherit {!VisitorsRuntime.iter} *); + concrete = true; + }] + +type fun_body = { + meta : meta; + arg_count : int; + locals : var list; + body : statement; +} +[@@deriving show] + +type fun_decl = { + def_id : FunDeclId.id; + meta : meta; + name : fun_name; + signature : fun_sig; + body : fun_body option; + is_global_decl_body : bool; +} +[@@deriving show] + +type global_decl = { + def_id : GlobalDeclId.id; + meta : meta; + body_id : FunDeclId.id; + name : global_name; + ty : ety; +} +[@@deriving show] diff --git a/compiler/LlbcAstUtils.ml b/compiler/LlbcAstUtils.ml new file mode 100644 index 00000000..46711d0a --- /dev/null +++ b/compiler/LlbcAstUtils.ml @@ -0,0 +1,73 @@ +open LlbcAst +open Utils +module T = Types + +(** Check if a {!type:LlbcAst.statement} contains loops *) +let statement_has_loops (st : statement) : bool = + let obj = + object + inherit [_] iter_statement + method! visit_Loop _ _ = raise Found + end + in + try + obj#visit_statement () st; + false + with Found -> true + +(** Check if a {!type:LlbcAst.fun_decl} contains loops *) +let fun_decl_has_loops (fd : fun_decl) : bool = + match fd.body with + | Some body -> statement_has_loops body.body + | None -> false + +let lookup_fun_sig (fun_id : fun_id) (fun_decls : fun_decl FunDeclId.Map.t) : + fun_sig = + match fun_id with + | Regular id -> (FunDeclId.Map.find id fun_decls).signature + | Assumed aid -> Assumed.get_assumed_sig aid + +let lookup_fun_name (fun_id : fun_id) (fun_decls : fun_decl FunDeclId.Map.t) : + Names.fun_name = + match fun_id with + | Regular id -> (FunDeclId.Map.find id fun_decls).name + | Assumed aid -> Assumed.get_assumed_name aid + +(** Small utility: list the transitive parents of a region var group. + We don't do that in an efficient manner, but it doesn't matter. + + TODO: rename to "list_ancestors_..." + + This list *doesn't* include the current region. + *) +let rec list_parent_region_groups (sg : fun_sig) (gid : T.RegionGroupId.id) : + T.RegionGroupId.Set.t = + let rg = T.RegionGroupId.nth sg.regions_hierarchy gid in + let parents = + List.fold_left + (fun s gid -> + (* Compute the parents *) + let parents = list_parent_region_groups sg gid in + (* Parents U current region *) + let parents = T.RegionGroupId.Set.add gid parents in + (* Make the union with the accumulator *) + T.RegionGroupId.Set.union s parents) + T.RegionGroupId.Set.empty rg.parents + in + parents + +(** Small utility: same as {!list_parent_region_groups}, but returns an ordered list. *) +let list_ordered_parent_region_groups (sg : fun_sig) (gid : T.RegionGroupId.id) + : T.RegionGroupId.id list = + let pset = list_parent_region_groups sg gid in + let parents = + List.filter + (fun (rg : T.region_var_group) -> T.RegionGroupId.Set.mem rg.id pset) + sg.regions_hierarchy + in + let parents = List.map (fun (rg : T.region_var_group) -> rg.id) parents in + parents + +let fun_body_get_input_vars (fbody : fun_body) : var list = + let locals = List.tl fbody.locals in + Collections.List.prefix fbody.arg_count locals diff --git a/compiler/LlbcOfJson.ml b/compiler/LlbcOfJson.ml new file mode 100644 index 00000000..79c9b756 --- /dev/null +++ b/compiler/LlbcOfJson.ml @@ -0,0 +1,915 @@ +(** Functions to load LLBC ASTs from json. + + Initially, we used [ppx_derive_yojson] to automate this. + However, [ppx_derive_yojson] expects formatting to be slightly + different from what [serde_rs] generates (because it uses [Yojson.Safe.t] + and not [Yojson.Basic.t]). + + TODO: we should check all that the integer values are in the proper range + *) + +open Yojson.Basic +open Names +open OfJsonBasic +open Identifiers +open Meta +module T = Types +module V = Values +module S = Scalars +module E = Expressions +module A = LlbcAst +module TU = TypesUtils +module AU = LlbcAstUtils +module LocalFileId = IdGen () +module VirtualFileId = IdGen () + +(** The default logger *) +let log = Logging.llbc_of_json_logger + +(** A file identifier *) +type file_id = LocalId of LocalFileId.id | VirtualId of VirtualFileId.id +[@@deriving show, ord] + +module OrderedIdToFile : Collections.OrderedType with type t = file_id = struct + type t = file_id + + let compare fid0 fid1 = compare_file_id fid0 fid1 + + let to_string id = + match id with + | LocalId id -> "Local " ^ LocalFileId.to_string id + | VirtualId id -> "Virtual " ^ VirtualFileId.to_string id + + let pp_t fmt x = Format.pp_print_string fmt (to_string x) + let show_t x = to_string x +end + +module IdToFile = Collections.MakeMap (OrderedIdToFile) + +type id_to_file_map = file_name IdToFile.t + +let file_id_of_json (js : json) : (file_id, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc [ ("LocalId", id) ] -> + let* id = LocalFileId.id_of_json id in + Ok (LocalId id) + | `Assoc [ ("VirtualId", id) ] -> + let* id = VirtualFileId.id_of_json id in + Ok (VirtualId id) + | _ -> Error "") + +let file_name_of_json (js : json) : (file_name, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc [ ("Virtual", name) ] -> + let* name = string_of_json name in + Ok (Virtual name) + | `Assoc [ ("Local", name) ] -> + let* name = string_of_json name in + Ok (Local name) + | _ -> Error "") + +(** Deserialize a map from file id to file name. + + In the serialized LLBC, the files in the loc spans are refered to by their + ids, in order to save space. In a functional language like OCaml this is + not necessary: we thus replace the file ids by the file name themselves in + the AST. + The "id to file" map is thus only used in the deserialization process. + *) +let id_to_file_of_json (js : json) : (id_to_file_map, string) result = + combine_error_msgs js __FUNCTION__ + ((* The map is stored as a list of pairs (key, value): we deserialize + * this list then convert it to a map *) + let* key_values = + list_of_json (pair_of_json file_id_of_json file_name_of_json) js + in + Ok (IdToFile.of_list key_values)) + +let loc_of_json (js : json) : (loc, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc [ ("line", line); ("col", col) ] -> + let* line = int_of_json line in + let* col = int_of_json col in + Ok { line; col } + | _ -> Error "") + +let span_of_json (id_to_file : id_to_file_map) (js : json) : + (span, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc [ ("file_id", file_id); ("beg", beg_loc); ("end", end_loc) ] -> + let* file_id = file_id_of_json file_id in + let file = IdToFile.find file_id id_to_file in + let* beg_loc = loc_of_json beg_loc in + let* end_loc = loc_of_json end_loc in + Ok { file; beg_loc; end_loc } + | _ -> Error "") + +let meta_of_json (id_to_file : id_to_file_map) (js : json) : + (meta, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc [ ("span", span); ("generated_from_span", generated_from_span) ] -> + let* span = span_of_json id_to_file span in + let* generated_from_span = + option_of_json (span_of_json id_to_file) generated_from_span + in + Ok { span; generated_from_span } + | _ -> Error "") + +let path_elem_of_json (js : json) : (path_elem, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc [ ("Ident", name) ] -> + let* name = string_of_json name in + Ok (Ident name) + | `Assoc [ ("Disambiguator", d) ] -> + let* d = Disambiguator.id_of_json d in + Ok (Disambiguator d) + | _ -> Error "") + +let name_of_json (js : json) : (name, string) result = + combine_error_msgs js __FUNCTION__ (list_of_json path_elem_of_json js) + +let fun_name_of_json (js : json) : (fun_name, string) result = + combine_error_msgs js __FUNCTION__ (name_of_json js) + +let type_var_of_json (js : json) : (T.type_var, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc [ ("index", index); ("name", name) ] -> + let* index = T.TypeVarId.id_of_json index in + let* name = string_of_json name in + Ok { T.index; name } + | _ -> Error "") + +let region_var_of_json (js : json) : (T.region_var, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc [ ("index", index); ("name", name) ] -> + let* index = T.RegionVarId.id_of_json index in + let* name = string_option_of_json name in + Ok { T.index; name } + | _ -> Error "") + +let region_of_json (js : json) : (T.RegionVarId.id T.region, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `String "Static" -> Ok T.Static + | `Assoc [ ("Var", rid) ] -> + let* rid = T.RegionVarId.id_of_json rid in + Ok (T.Var rid) + | _ -> Error "") + +let erased_region_of_json (js : json) : (T.erased_region, string) result = + combine_error_msgs js __FUNCTION__ + (match js with `String "Erased" -> Ok T.Erased | _ -> Error "") + +let integer_type_of_json (js : json) : (T.integer_type, string) result = + match js with + | `String "Isize" -> Ok T.Isize + | `String "I8" -> Ok T.I8 + | `String "I16" -> Ok T.I16 + | `String "I32" -> Ok T.I32 + | `String "I64" -> Ok T.I64 + | `String "I128" -> Ok T.I128 + | `String "Usize" -> Ok T.Usize + | `String "U8" -> Ok T.U8 + | `String "U16" -> Ok T.U16 + | `String "U32" -> Ok T.U32 + | `String "U64" -> Ok T.U64 + | `String "U128" -> Ok T.U128 + | _ -> Error ("integer_type_of_json failed on: " ^ show js) + +let ref_kind_of_json (js : json) : (T.ref_kind, string) result = + match js with + | `String "Mut" -> Ok T.Mut + | `String "Shared" -> Ok T.Shared + | _ -> Error ("ref_kind_of_json failed on: " ^ show js) + +let assumed_ty_of_json (js : json) : (T.assumed_ty, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `String "Box" -> Ok T.Box + | `String "Vec" -> Ok T.Vec + | `String "Option" -> Ok T.Option + | _ -> Error "") + +let type_id_of_json (js : json) : (T.type_id, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc [ ("Adt", id) ] -> + let* id = T.TypeDeclId.id_of_json id in + Ok (T.AdtId id) + | `String "Tuple" -> Ok T.Tuple + | `Assoc [ ("Assumed", aty) ] -> + let* aty = assumed_ty_of_json aty in + Ok (T.Assumed aty) + | _ -> Error "") + +let rec ty_of_json (r_of_json : json -> ('r, string) result) (js : json) : + ('r T.ty, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc [ ("Adt", `List [ id; regions; types ]) ] -> + let* id = type_id_of_json id in + let* regions = list_of_json r_of_json regions in + let* types = list_of_json (ty_of_json r_of_json) types in + (* Sanity check *) + (match id with T.Tuple -> assert (List.length regions = 0) | _ -> ()); + Ok (T.Adt (id, regions, types)) + | `Assoc [ ("TypeVar", `List [ id ]) ] -> + let* id = T.TypeVarId.id_of_json id in + Ok (T.TypeVar id) + | `String "Bool" -> Ok Bool + | `String "Char" -> Ok Char + | `String "`Never" -> Ok Never + | `Assoc [ ("Integer", `List [ int_ty ]) ] -> + let* int_ty = integer_type_of_json int_ty in + Ok (T.Integer int_ty) + | `String "Str" -> Ok Str + | `Assoc [ ("Array", `List [ ty ]) ] -> + let* ty = ty_of_json r_of_json ty in + Ok (T.Array ty) + | `Assoc [ ("Slice", `List [ ty ]) ] -> + let* ty = ty_of_json r_of_json ty in + Ok (T.Slice ty) + | `Assoc [ ("Ref", `List [ region; ty; ref_kind ]) ] -> + let* region = r_of_json region in + let* ty = ty_of_json r_of_json ty in + let* ref_kind = ref_kind_of_json ref_kind in + Ok (T.Ref (region, ty, ref_kind)) + | _ -> Error "") + +let sty_of_json (js : json) : (T.sty, string) result = + combine_error_msgs js __FUNCTION__ (ty_of_json region_of_json js) + +let ety_of_json (js : json) : (T.ety, string) result = + combine_error_msgs js __FUNCTION__ (ty_of_json erased_region_of_json js) + +let field_of_json (id_to_file : id_to_file_map) (js : json) : + (T.field, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc [ ("meta", meta); ("name", name); ("ty", ty) ] -> + let* meta = meta_of_json id_to_file meta in + let* name = option_of_json string_of_json name in + let* ty = sty_of_json ty in + Ok { T.meta; field_name = name; field_ty = ty } + | _ -> Error "") + +let variant_of_json (id_to_file : id_to_file_map) (js : json) : + (T.variant, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc [ ("meta", meta); ("name", name); ("fields", fields) ] -> + let* meta = meta_of_json id_to_file meta in + let* name = string_of_json name in + let* fields = list_of_json (field_of_json id_to_file) fields in + Ok { T.meta; variant_name = name; fields } + | _ -> Error "") + +let type_decl_kind_of_json (id_to_file : id_to_file_map) (js : json) : + (T.type_decl_kind, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc [ ("Struct", fields) ] -> + let* fields = list_of_json (field_of_json id_to_file) fields in + Ok (T.Struct fields) + | `Assoc [ ("Enum", variants) ] -> + let* variants = list_of_json (variant_of_json id_to_file) variants in + Ok (T.Enum variants) + | `String "Opaque" -> Ok T.Opaque + | _ -> Error "") + +let region_var_group_of_json (js : json) : (T.region_var_group, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc [ ("id", id); ("regions", regions); ("parents", parents) ] -> + let* id = T.RegionGroupId.id_of_json id in + let* regions = list_of_json T.RegionVarId.id_of_json regions in + let* parents = list_of_json T.RegionGroupId.id_of_json parents in + Ok { T.id; regions; parents } + | _ -> Error "") + +let region_var_groups_of_json (js : json) : (T.region_var_groups, string) result + = + combine_error_msgs js __FUNCTION__ (list_of_json region_var_group_of_json js) + +let type_decl_of_json (id_to_file : id_to_file_map) (js : json) : + (T.type_decl, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc + [ + ("def_id", def_id); + ("meta", meta); + ("name", name); + ("region_params", region_params); + ("type_params", type_params); + ("regions_hierarchy", regions_hierarchy); + ("kind", kind); + ] -> + let* def_id = T.TypeDeclId.id_of_json def_id in + let* meta = meta_of_json id_to_file meta in + let* name = name_of_json name in + let* region_params = list_of_json region_var_of_json region_params in + let* type_params = list_of_json type_var_of_json type_params in + let* kind = type_decl_kind_of_json id_to_file kind in + let* regions_hierarchy = region_var_groups_of_json regions_hierarchy in + Ok + { + T.def_id; + meta; + name; + region_params; + type_params; + kind; + regions_hierarchy; + } + | _ -> Error "") + +let var_of_json (js : json) : (A.var, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc [ ("index", index); ("name", name); ("ty", ty) ] -> + let* index = V.VarId.id_of_json index in + let* name = string_option_of_json name in + let* var_ty = ety_of_json ty in + Ok { A.index; name; var_ty } + | _ -> Error "") + +let big_int_of_json (js : json) : (V.big_int, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Int i -> Ok (Z.of_int i) + | `String is -> Ok (Z.of_string is) + | _ -> Error "") + +(** Deserialize a {!V.scalar_value} from JSON and **check the ranges**. + + Note that in practice we also check that the values are in range + in the interpreter functions. Still, it doesn't cost much to be + a bit conservative. + *) +let scalar_value_of_json (js : json) : (V.scalar_value, string) result = + let res = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc [ ("Isize", `List [ bi ]) ] -> + let* bi = big_int_of_json bi in + Ok { V.value = bi; int_ty = Isize } + | `Assoc [ ("I8", `List [ bi ]) ] -> + let* bi = big_int_of_json bi in + Ok { V.value = bi; int_ty = I8 } + | `Assoc [ ("I16", `List [ bi ]) ] -> + let* bi = big_int_of_json bi in + Ok { V.value = bi; int_ty = I16 } + | `Assoc [ ("I32", `List [ bi ]) ] -> + let* bi = big_int_of_json bi in + Ok { V.value = bi; int_ty = I32 } + | `Assoc [ ("I64", `List [ bi ]) ] -> + let* bi = big_int_of_json bi in + Ok { V.value = bi; int_ty = I64 } + | `Assoc [ ("I128", `List [ bi ]) ] -> + let* bi = big_int_of_json bi in + Ok { V.value = bi; int_ty = I128 } + | `Assoc [ ("Usize", `List [ bi ]) ] -> + let* bi = big_int_of_json bi in + Ok { V.value = bi; int_ty = Usize } + | `Assoc [ ("U8", `List [ bi ]) ] -> + let* bi = big_int_of_json bi in + Ok { V.value = bi; int_ty = U8 } + | `Assoc [ ("U16", `List [ bi ]) ] -> + let* bi = big_int_of_json bi in + Ok { V.value = bi; int_ty = U16 } + | `Assoc [ ("U32", `List [ bi ]) ] -> + let* bi = big_int_of_json bi in + Ok { V.value = bi; int_ty = U32 } + | `Assoc [ ("U64", `List [ bi ]) ] -> + let* bi = big_int_of_json bi in + Ok { V.value = bi; int_ty = U64 } + | `Assoc [ ("U128", `List [ bi ]) ] -> + let* bi = big_int_of_json bi in + Ok { V.value = bi; int_ty = U128 } + | _ -> Error "") + in + match res with + | Error _ -> res + | Ok sv -> + if not (S.check_scalar_value_in_range sv) then ( + log#serror ("Scalar value not in range: " ^ V.show_scalar_value sv); + raise (Failure ("Scalar value not in range: " ^ V.show_scalar_value sv))); + res + +let field_proj_kind_of_json (js : json) : (E.field_proj_kind, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc [ ("ProjAdt", `List [ def_id; opt_variant_id ]) ] -> + let* def_id = T.TypeDeclId.id_of_json def_id in + let* opt_variant_id = + option_of_json T.VariantId.id_of_json opt_variant_id + in + Ok (E.ProjAdt (def_id, opt_variant_id)) + | `Assoc [ ("ProjTuple", i) ] -> + let* i = int_of_json i in + Ok (E.ProjTuple i) + | `Assoc [ ("ProjOption", variant_id) ] -> + let* variant_id = T.VariantId.id_of_json variant_id in + Ok (E.ProjOption variant_id) + | _ -> Error "") + +let projection_elem_of_json (js : json) : (E.projection_elem, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `String "Deref" -> Ok E.Deref + | `String "DerefBox" -> Ok E.DerefBox + | `Assoc [ ("Field", `List [ proj_kind; field_id ]) ] -> + let* proj_kind = field_proj_kind_of_json proj_kind in + let* field_id = T.FieldId.id_of_json field_id in + Ok (E.Field (proj_kind, field_id)) + | _ -> Error ("projection_elem_of_json failed on:" ^ show js)) + +let projection_of_json (js : json) : (E.projection, string) result = + combine_error_msgs js __FUNCTION__ (list_of_json projection_elem_of_json js) + +let place_of_json (js : json) : (E.place, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc [ ("var_id", var_id); ("projection", projection) ] -> + let* var_id = V.VarId.id_of_json var_id in + let* projection = projection_of_json projection in + Ok { E.var_id; projection } + | _ -> Error "") + +let borrow_kind_of_json (js : json) : (E.borrow_kind, string) result = + match js with + | `String "Shared" -> Ok E.Shared + | `String "Mut" -> Ok E.Mut + | `String "TwoPhaseMut" -> Ok E.TwoPhaseMut + | _ -> Error ("borrow_kind_of_json failed on:" ^ show js) + +let unop_of_json (js : json) : (E.unop, string) result = + match js with + | `String "Not" -> Ok E.Not + | `String "Neg" -> Ok E.Neg + | `Assoc [ ("Cast", `List [ src_ty; tgt_ty ]) ] -> + let* src_ty = integer_type_of_json src_ty in + let* tgt_ty = integer_type_of_json tgt_ty in + Ok (E.Cast (src_ty, tgt_ty)) + | _ -> Error ("unop_of_json failed on:" ^ show js) + +let binop_of_json (js : json) : (E.binop, string) result = + match js with + | `String "BitXor" -> Ok E.BitXor + | `String "BitAnd" -> Ok E.BitAnd + | `String "BitOr" -> Ok E.BitOr + | `String "Eq" -> Ok E.Eq + | `String "Lt" -> Ok E.Lt + | `String "Le" -> Ok E.Le + | `String "Ne" -> Ok E.Ne + | `String "Ge" -> Ok E.Ge + | `String "Gt" -> Ok E.Gt + | `String "Div" -> Ok E.Div + | `String "Rem" -> Ok E.Rem + | `String "Add" -> Ok E.Add + | `String "Sub" -> Ok E.Sub + | `String "Mul" -> Ok E.Mul + | `String "Shl" -> Ok E.Shl + | `String "Shr" -> Ok E.Shr + | _ -> Error ("binop_of_json failed on:" ^ show js) + +let constant_value_of_json (js : json) : (V.constant_value, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc [ ("Scalar", scalar_value) ] -> + let* scalar_value = scalar_value_of_json scalar_value in + Ok (V.Scalar scalar_value) + | `Assoc [ ("Bool", v) ] -> + let* v = bool_of_json v in + Ok (V.Bool v) + | `Assoc [ ("Char", v) ] -> + let* v = char_of_json v in + Ok (V.Char v) + | `Assoc [ ("String", v) ] -> + let* v = string_of_json v in + Ok (V.String v) + | _ -> Error "") + +let operand_of_json (js : json) : (E.operand, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc [ ("Copy", place) ] -> + let* place = place_of_json place in + Ok (E.Copy place) + | `Assoc [ ("Move", place) ] -> + let* place = place_of_json place in + Ok (E.Move place) + | `Assoc [ ("Const", `List [ ty; cv ]) ] -> + let* ty = ety_of_json ty in + let* cv = constant_value_of_json cv in + Ok (E.Constant (ty, cv)) + | _ -> Error "") + +let aggregate_kind_of_json (js : json) : (E.aggregate_kind, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `String "AggregatedTuple" -> Ok E.AggregatedTuple + | `Assoc [ ("AggregatedOption", `List [ variant_id; ty ]) ] -> + let* variant_id = T.VariantId.id_of_json variant_id in + let* ty = ety_of_json ty in + Ok (E.AggregatedOption (variant_id, ty)) + | `Assoc [ ("AggregatedAdt", `List [ id; opt_variant_id; regions; tys ]) ] + -> + let* id = T.TypeDeclId.id_of_json id in + let* opt_variant_id = + option_of_json T.VariantId.id_of_json opt_variant_id + in + let* regions = list_of_json erased_region_of_json regions in + let* tys = list_of_json ety_of_json tys in + Ok (E.AggregatedAdt (id, opt_variant_id, regions, tys)) + | _ -> Error "") + +let rvalue_of_json (js : json) : (E.rvalue, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc [ ("Use", op) ] -> + let* op = operand_of_json op in + Ok (E.Use op) + | `Assoc [ ("Ref", `List [ place; borrow_kind ]) ] -> + let* place = place_of_json place in + let* borrow_kind = borrow_kind_of_json borrow_kind in + Ok (E.Ref (place, borrow_kind)) + | `Assoc [ ("UnaryOp", `List [ unop; op ]) ] -> + let* unop = unop_of_json unop in + let* op = operand_of_json op in + Ok (E.UnaryOp (unop, op)) + | `Assoc [ ("BinaryOp", `List [ binop; op1; op2 ]) ] -> + let* binop = binop_of_json binop in + let* op1 = operand_of_json op1 in + let* op2 = operand_of_json op2 in + Ok (E.BinaryOp (binop, op1, op2)) + | `Assoc [ ("Discriminant", place) ] -> + let* place = place_of_json place in + Ok (E.Discriminant place) + | `Assoc [ ("Aggregate", `List [ aggregate_kind; ops ]) ] -> + let* aggregate_kind = aggregate_kind_of_json aggregate_kind in + let* ops = list_of_json operand_of_json ops in + Ok (E.Aggregate (aggregate_kind, ops)) + | _ -> Error "") + +let assumed_fun_id_of_json (js : json) : (A.assumed_fun_id, string) result = + match js with + | `String "Replace" -> Ok A.Replace + | `String "BoxNew" -> Ok A.BoxNew + | `String "BoxDeref" -> Ok A.BoxDeref + | `String "BoxDerefMut" -> Ok A.BoxDerefMut + | `String "BoxFree" -> Ok A.BoxFree + | `String "VecNew" -> Ok A.VecNew + | `String "VecPush" -> Ok A.VecPush + | `String "VecInsert" -> Ok A.VecInsert + | `String "VecLen" -> Ok A.VecLen + | `String "VecIndex" -> Ok A.VecIndex + | `String "VecIndexMut" -> Ok A.VecIndexMut + | _ -> Error ("assumed_fun_id_of_json failed on:" ^ show js) + +let fun_id_of_json (js : json) : (A.fun_id, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc [ ("Regular", id) ] -> + let* id = A.FunDeclId.id_of_json id in + Ok (A.Regular id) + | `Assoc [ ("Assumed", fid) ] -> + let* fid = assumed_fun_id_of_json fid in + Ok (A.Assumed fid) + | _ -> Error "") + +let assertion_of_json (js : json) : (A.assertion, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc [ ("cond", cond); ("expected", expected) ] -> + let* cond = operand_of_json cond in + let* expected = bool_of_json expected in + Ok { A.cond; expected } + | _ -> Error "") + +let fun_sig_of_json (js : json) : (A.fun_sig, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc + [ + ("region_params", region_params); + ("num_early_bound_regions", num_early_bound_regions); + ("regions_hierarchy", regions_hierarchy); + ("type_params", type_params); + ("inputs", inputs); + ("output", output); + ] -> + let* region_params = list_of_json region_var_of_json region_params in + let* num_early_bound_regions = int_of_json num_early_bound_regions in + let* regions_hierarchy = region_var_groups_of_json regions_hierarchy in + let* type_params = list_of_json type_var_of_json type_params in + let* inputs = list_of_json sty_of_json inputs in + let* output = sty_of_json output in + Ok + { + A.region_params; + num_early_bound_regions; + regions_hierarchy; + type_params; + inputs; + output; + } + | _ -> Error "") + +let call_of_json (js : json) : (A.call, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc + [ + ("func", func); + ("region_args", region_args); + ("type_args", type_args); + ("args", args); + ("dest", dest); + ] -> + let* func = fun_id_of_json func in + let* region_args = list_of_json erased_region_of_json region_args in + let* type_args = list_of_json ety_of_json type_args in + let* args = list_of_json operand_of_json args in + let* dest = place_of_json dest in + Ok { A.func; region_args; type_args; args; dest } + | _ -> Error "") + +let rec statement_of_json (id_to_file : id_to_file_map) (js : json) : + (A.statement, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc [ ("meta", meta); ("content", content) ] -> + let* meta = meta_of_json id_to_file meta in + let* content = raw_statement_of_json id_to_file content in + Ok { A.meta; content } + | _ -> Error "") + +and raw_statement_of_json (id_to_file : id_to_file_map) (js : json) : + (A.raw_statement, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc [ ("Assign", `List [ place; rvalue ]) ] -> + let* place = place_of_json place in + let* rvalue = rvalue_of_json rvalue in + Ok (A.Assign (place, rvalue)) + | `Assoc [ ("AssignGlobal", `List [ dst; global ]) ] -> + let* dst = V.VarId.id_of_json dst in + let* global = A.GlobalDeclId.id_of_json global in + Ok (A.AssignGlobal { dst; global }) + | `Assoc [ ("FakeRead", place) ] -> + let* place = place_of_json place in + Ok (A.FakeRead place) + | `Assoc [ ("SetDiscriminant", `List [ place; variant_id ]) ] -> + let* place = place_of_json place in + let* variant_id = T.VariantId.id_of_json variant_id in + Ok (A.SetDiscriminant (place, variant_id)) + | `Assoc [ ("Drop", place) ] -> + let* place = place_of_json place in + Ok (A.Drop place) + | `Assoc [ ("Assert", assertion) ] -> + let* assertion = assertion_of_json assertion in + Ok (A.Assert assertion) + | `Assoc [ ("Call", call) ] -> + let* call = call_of_json call in + Ok (A.Call call) + | `String "Panic" -> Ok A.Panic + | `String "Return" -> Ok A.Return + | `Assoc [ ("Break", i) ] -> + let* i = int_of_json i in + Ok (A.Break i) + | `Assoc [ ("Continue", i) ] -> + let* i = int_of_json i in + Ok (A.Continue i) + | `String "Nop" -> Ok A.Nop + | `Assoc [ ("Sequence", `List [ st1; st2 ]) ] -> + let* st1 = statement_of_json id_to_file st1 in + let* st2 = statement_of_json id_to_file st2 in + Ok (A.Sequence (st1, st2)) + | `Assoc [ ("Switch", `List [ op; tgt ]) ] -> + let* op = operand_of_json op in + let* tgt = switch_targets_of_json id_to_file tgt in + Ok (A.Switch (op, tgt)) + | `Assoc [ ("Loop", st) ] -> + let* st = statement_of_json id_to_file st in + Ok (A.Loop st) + | _ -> Error "") + +and switch_targets_of_json (id_to_file : id_to_file_map) (js : json) : + (A.switch_targets, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc [ ("If", `List [ st1; st2 ]) ] -> + let* st1 = statement_of_json id_to_file st1 in + let* st2 = statement_of_json id_to_file st2 in + Ok (A.If (st1, st2)) + | `Assoc [ ("SwitchInt", `List [ int_ty; tgts; otherwise ]) ] -> + let* int_ty = integer_type_of_json int_ty in + let* tgts = + list_of_json + (pair_of_json + (list_of_json scalar_value_of_json) + (statement_of_json id_to_file)) + tgts + in + let* otherwise = statement_of_json id_to_file otherwise in + Ok (A.SwitchInt (int_ty, tgts, otherwise)) + | _ -> Error "") + +let fun_body_of_json (id_to_file : id_to_file_map) (js : json) : + (A.fun_body, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc + [ + ("meta", meta); + ("arg_count", arg_count); + ("locals", locals); + ("body", body); + ] -> + let* meta = meta_of_json id_to_file meta in + let* arg_count = int_of_json arg_count in + let* locals = list_of_json var_of_json locals in + let* body = statement_of_json id_to_file body in + Ok { A.meta; arg_count; locals; body } + | _ -> Error "") + +let fun_decl_of_json (id_to_file : id_to_file_map) (js : json) : + (A.fun_decl, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc + [ + ("def_id", def_id); + ("meta", meta); + ("name", name); + ("signature", signature); + ("body", body); + ] -> + let* def_id = A.FunDeclId.id_of_json def_id in + let* meta = meta_of_json id_to_file meta in + let* name = fun_name_of_json name in + let* signature = fun_sig_of_json signature in + let* body = option_of_json (fun_body_of_json id_to_file) body in + Ok + { A.def_id; meta; name; signature; body; is_global_decl_body = false } + | _ -> Error "") + +(* Strict type for the number of function declarations (see {!global_to_fun_id} below) *) +type global_id_converter = { fun_count : int } [@@deriving show] + +(** Converts a global id to its corresponding function id. + To do so, it adds the global id to the number of function declarations : + We have the bijection [global_fun_id <=> global_id + fun_id_count]. +*) +let global_to_fun_id (conv : global_id_converter) (gid : A.GlobalDeclId.id) : + A.FunDeclId.id = + A.FunDeclId.of_int (A.GlobalDeclId.to_int gid + conv.fun_count) + +(* Converts a global declaration to a function declaration. + *) +let global_decl_of_json (id_to_file : id_to_file_map) (js : json) + (gid_conv : global_id_converter) : + (A.global_decl * A.fun_decl, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc + [ + ("def_id", def_id); + ("meta", meta); + ("name", name); + ("ty", ty); + ("body", body); + ] -> + let* global_id = A.GlobalDeclId.id_of_json def_id in + let fun_id = global_to_fun_id gid_conv global_id in + let* meta = meta_of_json id_to_file meta in + let* name = fun_name_of_json name in + let* ty = ety_of_json ty in + let* body = option_of_json (fun_body_of_json id_to_file) body in + let signature : A.fun_sig = + { + region_params = []; + num_early_bound_regions = 0; + regions_hierarchy = []; + type_params = []; + inputs = []; + output = TU.ety_no_regions_to_sty ty; + } + in + Ok + ( { A.def_id = global_id; meta; body_id = fun_id; name; ty }, + { + A.def_id = fun_id; + meta; + name; + signature; + body; + is_global_decl_body = true; + } ) + | _ -> Error "") + +let g_declaration_group_of_json (id_of_json : json -> ('id, string) result) + (js : json) : ('id Crates.g_declaration_group, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc [ ("NonRec", `List [ id ]) ] -> + let* id = id_of_json id in + Ok (Crates.NonRec id) + | `Assoc [ ("Rec", `List [ ids ]) ] -> + let* ids = list_of_json id_of_json ids in + Ok (Crates.Rec ids) + | _ -> Error "") + +let type_declaration_group_of_json (js : json) : + (Crates.type_declaration_group, string) result = + combine_error_msgs js __FUNCTION__ + (g_declaration_group_of_json T.TypeDeclId.id_of_json js) + +let fun_declaration_group_of_json (js : json) : + (Crates.fun_declaration_group, string) result = + combine_error_msgs js __FUNCTION__ + (g_declaration_group_of_json A.FunDeclId.id_of_json js) + +let global_declaration_group_of_json (js : json) : + (A.GlobalDeclId.id, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc [ ("NonRec", `List [ id ]) ] -> + let* id = A.GlobalDeclId.id_of_json id in + Ok id + | `Assoc [ ("Rec", `List [ _ ]) ] -> Error "got mutually dependent globals" + | _ -> Error "") + +let declaration_group_of_json (js : json) : + (Crates.declaration_group, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc [ ("Type", `List [ decl ]) ] -> + let* decl = type_declaration_group_of_json decl in + Ok (Crates.Type decl) + | `Assoc [ ("Fun", `List [ decl ]) ] -> + let* decl = fun_declaration_group_of_json decl in + Ok (Crates.Fun decl) + | `Assoc [ ("Global", `List [ decl ]) ] -> + let* id = global_declaration_group_of_json decl in + Ok (Crates.Global id) + | _ -> Error "") + +let length_of_json_list (js : json) : (int, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `List jsl -> Ok (List.length jsl) + | _ -> Error ("not a list: " ^ show js)) + +let llbc_crate_of_json (js : json) : (Crates.llbc_crate, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc + [ + ("name", name); + ("id_to_file", id_to_file); + ("declarations", declarations); + ("types", types); + ("functions", functions); + ("globals", globals); + ] -> + (* We first deserialize the declaration groups (which simply contain ids) + * and all the declarations *butù* the globals *) + let* name = string_of_json name in + let* id_to_file = id_to_file_of_json id_to_file in + let* declarations = + list_of_json declaration_group_of_json declarations + in + let* types = list_of_json (type_decl_of_json id_to_file) types in + let* functions = list_of_json (fun_decl_of_json id_to_file) functions in + (* When deserializing the globals, we split the global declarations + * between the globals themselves and their bodies, which are simply + * functions with no arguments. We add the global bodies to the list + * of function declarations: the (fresh) ids we use for those bodies + * are simply given by: [num_functions + global_id] *) + let gid_conv = { fun_count = List.length functions } in + let* globals = + list_of_json + (fun js -> global_decl_of_json id_to_file js gid_conv) + globals + in + let globals, global_bodies = List.split globals in + Ok + { + Crates.name; + declarations; + types; + functions = functions @ global_bodies; + globals; + } + | _ -> Error "") diff --git a/compiler/Logging.ml b/compiler/Logging.ml new file mode 100644 index 00000000..e83f25f8 --- /dev/null +++ b/compiler/Logging.ml @@ -0,0 +1,179 @@ +module H = Easy_logging.Handlers +module L = Easy_logging.Logging + +let _ = L.make_logger "MainLogger" Debug [ Cli Debug ] + +(** The main logger *) +let main_log = L.get_logger "MainLogger" + +(** Below, we create subgloggers for various submodules, so that we can precisely + toggle logging on/off, depending on which information we need *) + +(** Logger for LlbcOfJson *) +let llbc_of_json_logger = L.get_logger "MainLogger.LlbcOfJson" + +(** Logger for PrePasses *) +let pre_passes_log = L.get_logger "MainLogger.PrePasses" + +(** Logger for Translate *) +let translate_log = L.get_logger "MainLogger.Translate" + +(** Logger for PureUtils *) +let pure_utils_log = L.get_logger "MainLogger.PureUtils" + +(** Logger for SymbolicToPure *) +let symbolic_to_pure_log = L.get_logger "MainLogger.SymbolicToPure" + +(** Logger for PureMicroPasses *) +let pure_micro_passes_log = L.get_logger "MainLogger.PureMicroPasses" + +(** Logger for PureToExtract *) +let pure_to_extract_log = L.get_logger "MainLogger.PureToExtract" + +(** Logger for Interpreter *) +let interpreter_log = L.get_logger "MainLogger.Interpreter" + +(** Logger for InterpreterStatements *) +let statements_log = L.get_logger "MainLogger.Interpreter.Statements" + +(** Logger for InterpreterExpressions *) +let expressions_log = L.get_logger "MainLogger.Interpreter.Expressions" + +(** Logger for InterpreterPaths *) +let paths_log = L.get_logger "MainLogger.Interpreter.Paths" + +(** Logger for InterpreterExpansion *) +let expansion_log = L.get_logger "MainLogger.Interpreter.Expansion" + +(** Logger for InterpreterBorrows *) +let borrows_log = L.get_logger "MainLogger.Interpreter.Borrows" + +(** Logger for Invariants *) +let invariants_log = L.get_logger "MainLogger.Interpreter.Invariants" + +(** Terminal colors - TODO: comes from easy_logging (did not manage to reuse the module directly) *) +type color = + | Default + | Black + | Red + | Green + | Yellow + | Blue + | Magenta + | Cyan + | Gray + | White + | LRed + | LGreen + | LYellow + | LBlue + | LMagenta + | LCyan + | LGray + +(** Terminal styles - TODO: comes from easy_logging (did not manage to reuse the module directly) *) +type format = Bold | Underline | Invert | Fg of color | Bg of color + +(** TODO: comes from easy_logging (did not manage to reuse the module directly) *) +let to_fg_code c = + match c with + | Default -> 39 + | Black -> 30 + | Red -> 31 + | Green -> 32 + | Yellow -> 33 + | Blue -> 34 + | Magenta -> 35 + | Cyan -> 36 + | Gray -> 90 + | White -> 97 + | LRed -> 91 + | LGreen -> 92 + | LYellow -> 93 + | LBlue -> 94 + | LMagenta -> 95 + | LCyan -> 96 + | LGray -> 37 + +(** TODO: comes from easy_logging (did not manage to reuse the module directly) *) +let to_bg_code c = + match c with + | Default -> 49 + | Black -> 40 + | Red -> 41 + | Green -> 42 + | Yellow -> 43 + | Blue -> 44 + | Magenta -> 45 + | Cyan -> 46 + | Gray -> 100 + | White -> 107 + | LRed -> 101 + | LGreen -> 102 + | LYellow -> 103 + | LBlue -> 104 + | LMagenta -> 105 + | LCyan -> 106 + | LGray -> 47 + +(** TODO: comes from easy_logging (did not manage to reuse the module directly) *) +let style_to_codes s = + match s with + | Bold -> (1, 21) + | Underline -> (4, 24) + | Invert -> (7, 27) + | Fg c -> (to_fg_code c, to_fg_code Default) + | Bg c -> (to_bg_code c, to_bg_code Default) + +(** TODO: comes from easy_logging (did not manage to reuse the module directly) + I made a minor modifications, though. *) +let level_to_color (lvl : L.level) = + match lvl with + | L.Flash -> LMagenta + | Error -> LRed + | Warning -> LYellow + | Info -> LGreen + | Trace -> Cyan + | Debug -> LBlue + | NoLevel -> Default + +(** [format styles str] formats [str] to the given [styles] - + TODO: comes from {{: http://ocamlverse.net/content/documentation_guidelines.html}[easy_logging]} + (did not manage to reuse the module directly) +*) +let rec format styles str = + match styles with + | (_ as s) :: styles' -> + let set, reset = style_to_codes s in + Printf.sprintf "\027[%dm%s\027[%dm" set (format styles' str) reset + | [] -> str + +(** TODO: comes from {{: http://ocamlverse.net/content/documentation_guidelines.html}[easy_logging]} + (did not manage to reuse the module directly) *) +let format_tags (tags : string list) = + match tags with + | [] -> "" + | _ -> + let elems_str = String.concat " | " tags in + "[" ^ elems_str ^ "] " + +(* Change the formatters *) +let main_logger_handler = + (* TODO: comes from easy_logging *) + let formatter (item : L.log_item) : string = + let item_level_fmt = + format [ Fg (level_to_color item.level) ] (L.show_level item.level) + and item_msg_fmt = + match item.level with + | Flash -> format [ Fg Black; Bg LMagenta ] item.msg + | _ -> item.msg + in + + Format.pp_set_max_indent Format.str_formatter 200; + Format.sprintf "@[[%-15s] %s%s@]" item_level_fmt (format_tags item.tags) + item_msg_fmt + in + (* There should be exactly one handler *) + let handlers = main_log#get_handlers in + List.iter (fun h -> H.set_formatter h formatter) handlers; + match handlers with [ handler ] -> handler | _ -> failwith "Unexpected" diff --git a/compiler/Meta.ml b/compiler/Meta.ml new file mode 100644 index 00000000..f0e4ca04 --- /dev/null +++ b/compiler/Meta.ml @@ -0,0 +1,44 @@ +(** Meta data like code spans *) + +(** A line location *) +type loc = { + line : int; (** The (1-based) line number. *) + col : int; (** The (0-based) column offset. *) +} +[@@deriving show] + +type file_name = + | Virtual of string (** A remapped path (namely paths into stdlib) *) + | Local of string + (** A local path (a file coming from the current crate for instance) *) +[@@deriving show] + +(** Span data *) +type span = { file : file_name; beg_loc : loc; end_loc : loc } [@@deriving show] + +type meta = { + span : span; + (** The source code span. + + If this meta information is for a statement/terminator coming from a macro + expansion/inlining/etc., this span is (in case of macros) for the macro + before expansion (i.e., the location the code where the user wrote the call + to the macro). + + Ex: + {[ + // Below, we consider the spans for the statements inside `test` + + // the statement we consider, which gets inlined in `test` + VV + macro_rules! macro { ... st ... } // `generated_from_span` refers to this location + + fn test() { + macro!(); // <-- `span` refers to this location + } + ]} + *) + generated_from_span : span option; + (** Where the code actually comes from, in case of macro expansion/inlining/etc. *) +} +[@@deriving show] diff --git a/compiler/Names.ml b/compiler/Names.ml new file mode 100644 index 00000000..a27db161 --- /dev/null +++ b/compiler/Names.ml @@ -0,0 +1,80 @@ +open Identifiers +module Disambiguator = IdGen () + +(** See the comments for [Name] *) +type path_elem = Ident of string | Disambiguator of Disambiguator.id +[@@deriving show, ord] + +(** A name such as: [std::collections::vector] (which would be represented as + [[Ident "std"; Ident "collections"; Ident "vector"]]) + + + A name really is a list of strings. However, we sometimes need to + introduce unique indices to disambiguate. This mostly happens because + of "impl" blocks in Rust: + {[ + impl List { + ... + } + ]} + + A type in Rust can have several "impl" blocks, and those blocks can + contain items with similar names. For this reason, we need to disambiguate + them with unique indices. Rustc calls those "disambiguators". In rustc, this + gives names like this: + - [betree_main::betree::NodeIdCounter{impl#0}::new] + - note that impl blocks can be nested, and macros sometimes generate + weird names (which require disambiguation): + [betree_main::betree_utils::_#1::{impl#0}::deserialize::{impl#0}] + + Finally, the paths used by rustc are a lot more precise and explicit than + those we expose in LLBC: for instance, every identifier belongs to a specific + namespace (value namespace, type namespace, etc.), and is coupled with a + disambiguator. + + On our side, we want to stay high-level and simple: we use string identifiers + as much as possible, insert disambiguators only when necessary (whenever + we find an "impl" block, typically) and check that the disambiguator is useless + in the other situations (i.e., the disambiguator is always equal to 0). + + Moreover, the items are uniquely disambiguated by their (integer) ids + ([TypeDeclId.id], etc.), and when extracting the code we have to deal with + name clashes anyway. Still, we might want to be more precise in the future. + + Also note that the first path element in the name is always the crate name. + *) +type name = path_elem list [@@deriving show, ord] + +let to_name (ls : string list) : name = List.map (fun s -> Ident s) ls + +type module_name = name [@@deriving show, ord] +type type_name = name [@@deriving show, ord] +type fun_name = name [@@deriving show, ord] +type global_name = name [@@deriving show, ord] + +(** Filter the disambiguators equal to 0 in a name *) +let filter_disambiguators_zero (n : name) : name = + let pred (pe : path_elem) : bool = + match pe with Ident _ -> true | Disambiguator d -> d <> Disambiguator.zero + in + List.filter pred n + +(** Filter the disambiguators in a name *) +let filter_disambiguators (n : name) : name = + let pred (pe : path_elem) : bool = + match pe with Ident _ -> true | Disambiguator _ -> false + in + List.filter pred n + +let as_ident (pe : path_elem) : string = + match pe with + | Ident s -> s + | Disambiguator _ -> raise (Failure "Improper variant") + +let path_elem_to_string (pe : path_elem) : string = + match pe with + | Ident s -> s + | Disambiguator d -> "{" ^ Disambiguator.to_string d ^ "}" + +let name_to_string (name : name) : string = + String.concat "::" (List.map path_elem_to_string name) diff --git a/compiler/OfJsonBasic.ml b/compiler/OfJsonBasic.ml new file mode 100644 index 00000000..07daf03d --- /dev/null +++ b/compiler/OfJsonBasic.ml @@ -0,0 +1,75 @@ +(** This module defines various basic utilities for json deserialization. + + *) + +open Yojson.Basic + +type json = t + +let ( let* ) o f = match o with Error e -> Error e | Ok x -> f x + +let combine_error_msgs js msg res : ('a, string) result = + match res with + | Ok x -> Ok x + | Error e -> Error ("[" ^ msg ^ "]" ^ " failed on: " ^ show js ^ "\n\n" ^ e) + +let bool_of_json (js : json) : (bool, string) result = + match js with + | `Bool b -> Ok b + | _ -> Error ("bool_of_json: not a bool: " ^ show js) + +let int_of_json (js : json) : (int, string) result = + match js with + | `Int i -> Ok i + | _ -> Error ("int_of_json: not an int: " ^ show js) + +let char_of_json (js : json) : (char, string) result = + match js with + | `String c -> + if String.length c = 1 then Ok c.[0] + else Error ("char_of_json: stricly more than one character in: " ^ show js) + | _ -> Error ("char_of_json: not a char: " ^ show js) + +let rec of_json_list (a_of_json : json -> ('a, string) result) (jsl : json list) + : ('a list, string) result = + match jsl with + | [] -> Ok [] + | x :: jsl' -> + let* x = a_of_json x in + let* jsl' = of_json_list a_of_json jsl' in + Ok (x :: jsl') + +let pair_of_json (a_of_json : json -> ('a, string) result) + (b_of_json : json -> ('b, string) result) (js : json) : + ('a * 'b, string) result = + match js with + | `List [ a; b ] -> + let* a = a_of_json a in + let* b = b_of_json b in + Ok (a, b) + | _ -> Error ("pair_of_json failed on: " ^ show js) + +let list_of_json (a_of_json : json -> ('a, string) result) (js : json) : + ('a list, string) result = + combine_error_msgs js "list_of_json" + (match js with + | `List jsl -> of_json_list a_of_json jsl + | _ -> Error ("not a list: " ^ show js)) + +let string_of_json (js : json) : (string, string) result = + match js with + | `String str -> Ok str + | _ -> Error ("string_of_json: not a string: " ^ show js) + +let option_of_json (a_of_json : json -> ('a, string) result) (js : json) : + ('a option, string) result = + combine_error_msgs js "option_of_json" + (match js with + | `Null -> Ok None + | _ -> + let* x = a_of_json js in + Ok (Some x)) + +let string_option_of_json (js : json) : (string option, string) result = + combine_error_msgs js "string_option_of_json" + (option_of_json string_of_json js) diff --git a/compiler/PrePasses.ml b/compiler/PrePasses.ml new file mode 100644 index 00000000..a09ae476 --- /dev/null +++ b/compiler/PrePasses.ml @@ -0,0 +1,54 @@ +(** This files contains passes we apply on the AST *before* calling the + (concrete/symbolic) interpreter on it + *) + +module T = Types +module V = Values +module E = Expressions +module C = Contexts +module A = LlbcAst +module L = Logging + +let log = L.pre_passes_log + +(** Rustc inserts a lot of drops before the assignments. + We consider those drops are part of the assignment, and splitting the + drop and the assignment is problematic for us because it can introduce + [⊥] under borrows. For instance, we encountered situations like the + following one: + + {[ + drop( *x ); // Illegal! Inserts a ⊥ under a borrow + *x = move ...; + ]} + + TODO: this is not necessary anymore + *) +let filter_drop_assigns (f : A.fun_decl) : A.fun_decl = + (* The visitor *) + let obj = + object (self) + inherit [_] A.map_statement as super + + method! visit_Sequence env st1 st2 = + match (st1.content, st2.content) with + | Drop p1, Assign (p2, _) -> + if p1 = p2 then (self#visit_statement env st2).content + else super#visit_Sequence env st1 st2 + | Drop p1, Sequence ({ content = Assign (p2, _); meta = _ }, _) -> + if p1 = p2 then (self#visit_statement env st2).content + else super#visit_Sequence env st1 st2 + | _ -> super#visit_Sequence env st1 st2 + end + in + (* Map *) + let body = + match f.body with + | Some body -> Some { body with body = obj#visit_statement () body.body } + | None -> None + in + { f with body } + +let apply_passes (m : Crates.llbc_crate) : Crates.llbc_crate = + let functions = List.map filter_drop_assigns m.functions in + { m with functions } diff --git a/compiler/Print.ml b/compiler/Print.ml new file mode 100644 index 00000000..8f52b291 --- /dev/null +++ b/compiler/Print.ml @@ -0,0 +1,1283 @@ +open Names +module T = Types +module TU = TypesUtils +module V = Values +module VU = ValuesUtils +module E = Expressions +module A = LlbcAst +module C = Contexts + +let option_to_string (to_string : 'a -> string) (x : 'a option) : string = + match x with Some x -> "Some (" ^ to_string x ^ ")" | None -> "None" + +let name_to_string (name : name) : string = Names.name_to_string name +let fun_name_to_string (name : fun_name) : string = name_to_string name +let global_name_to_string (name : global_name) : string = name_to_string name + +(** Pretty-printing for types *) +module Types = struct + let type_var_to_string (tv : T.type_var) : string = tv.name + + let region_var_to_string (rv : T.region_var) : string = + match rv.name with + | Some name -> name + | None -> T.RegionVarId.to_string rv.index + + let region_var_id_to_string (rid : T.RegionVarId.id) : string = + "rv@" ^ T.RegionVarId.to_string rid + + let region_id_to_string (rid : T.RegionId.id) : string = + "r@" ^ T.RegionId.to_string rid + + let region_to_string (rid_to_string : 'rid -> string) (r : 'rid T.region) : + string = + match r with Static -> "'static" | Var rid -> rid_to_string rid + + let erased_region_to_string (_ : T.erased_region) : string = "'_" + + let ref_kind_to_string (rk : T.ref_kind) : string = + match rk with Mut -> "Mut" | Shared -> "Shared" + + let assumed_ty_to_string (_ : T.assumed_ty) : string = "Box" + + type 'r type_formatter = { + r_to_string : 'r -> string; + type_var_id_to_string : T.TypeVarId.id -> string; + type_decl_id_to_string : T.TypeDeclId.id -> string; + } + + type stype_formatter = T.RegionVarId.id T.region type_formatter + type rtype_formatter = T.RegionId.id T.region type_formatter + type etype_formatter = T.erased_region type_formatter + + let integer_type_to_string = function + | T.Isize -> "isize" + | T.I8 -> "i8" + | T.I16 -> "i16" + | T.I32 -> "i32" + | T.I64 -> "i64" + | T.I128 -> "i128" + | T.Usize -> "usize" + | T.U8 -> "u8" + | T.U16 -> "u16" + | T.U32 -> "u32" + | T.U64 -> "u64" + | T.U128 -> "u128" + + let type_id_to_string (fmt : 'r type_formatter) (id : T.type_id) : string = + match id with + | T.AdtId id -> fmt.type_decl_id_to_string id + | T.Tuple -> "" + | T.Assumed aty -> ( + match aty with + | Box -> "alloc::boxed::Box" + | Vec -> "alloc::vec::Vec" + | Option -> "core::option::Option") + + let rec ty_to_string (fmt : 'r type_formatter) (ty : 'r T.ty) : string = + match ty with + | T.Adt (id, regions, tys) -> + let is_tuple = match id with T.Tuple -> true | _ -> false in + let params = params_to_string fmt is_tuple regions tys in + type_id_to_string fmt id ^ params + | T.TypeVar tv -> fmt.type_var_id_to_string tv + | T.Bool -> "bool" + | T.Char -> "char" + | T.Never -> "⊥" + | T.Integer int_ty -> integer_type_to_string int_ty + | T.Str -> "str" + | T.Array aty -> "[" ^ ty_to_string fmt aty ^ "; ?]" + | T.Slice sty -> "[" ^ ty_to_string fmt sty ^ "]" + | T.Ref (r, rty, ref_kind) -> ( + match ref_kind with + | T.Mut -> + "&" ^ fmt.r_to_string r ^ " mut (" ^ ty_to_string fmt rty ^ ")" + | T.Shared -> + "&" ^ fmt.r_to_string r ^ " (" ^ ty_to_string fmt rty ^ ")") + + and params_to_string (fmt : 'r type_formatter) (is_tuple : bool) + (regions : 'r list) (types : 'r T.ty list) : string = + let regions = List.map fmt.r_to_string regions in + let types = List.map (ty_to_string fmt) types in + let params = String.concat ", " (List.append regions types) in + if is_tuple then "(" ^ params ^ ")" + else if List.length regions + List.length types > 0 then "<" ^ params ^ ">" + else "" + + let sty_to_string (fmt : stype_formatter) (ty : T.sty) : string = + ty_to_string fmt ty + + let rty_to_string (fmt : rtype_formatter) (ty : T.rty) : string = + ty_to_string fmt ty + + let ety_to_string (fmt : etype_formatter) (ty : T.ety) : string = + ty_to_string fmt ty + + let field_to_string fmt (f : T.field) : string = + match f.field_name with + | Some field_name -> field_name ^ " : " ^ ty_to_string fmt f.field_ty + | None -> ty_to_string fmt f.field_ty + + let variant_to_string fmt (v : T.variant) : string = + v.variant_name ^ "(" + ^ String.concat ", " (List.map (field_to_string fmt) v.fields) + ^ ")" + + let type_decl_to_string (type_decl_id_to_string : T.TypeDeclId.id -> string) + (def : T.type_decl) : string = + let regions = def.region_params in + let types = def.type_params in + let rid_to_string rid = + match List.find_opt (fun rv -> rv.T.index = rid) regions with + | Some rv -> region_var_to_string rv + | None -> failwith "Unreachable" + in + let r_to_string = region_to_string rid_to_string in + let type_var_id_to_string id = + match List.find_opt (fun tv -> tv.T.index = id) types with + | Some tv -> type_var_to_string tv + | None -> failwith "Unreachable" + in + let fmt = { r_to_string; type_var_id_to_string; type_decl_id_to_string } in + let name = name_to_string def.name in + let params = + if List.length regions + List.length types > 0 then + let regions = List.map region_var_to_string regions in + let types = List.map type_var_to_string types in + let params = String.concat ", " (List.append regions types) in + "<" ^ params ^ ">" + else "" + in + match def.kind with + | T.Struct fields -> + if List.length fields > 0 then + let fields = + String.concat "," + (List.map (fun f -> "\n " ^ field_to_string fmt f) fields) + in + "struct " ^ name ^ params ^ "{" ^ fields ^ "}" + else "struct " ^ name ^ params ^ "{}" + | T.Enum variants -> + let variants = + List.map (fun v -> "| " ^ variant_to_string fmt v) variants + in + let variants = String.concat "\n" variants in + "enum " ^ name ^ params ^ " =\n" ^ variants + | T.Opaque -> "opaque type " ^ name ^ params +end + +module PT = Types (* local module *) + +(** Pretty-printing for values *) +module Values = struct + type value_formatter = { + rvar_to_string : T.RegionVarId.id -> string; + r_to_string : T.RegionId.id -> string; + type_var_id_to_string : T.TypeVarId.id -> string; + type_decl_id_to_string : T.TypeDeclId.id -> string; + adt_variant_to_string : T.TypeDeclId.id -> T.VariantId.id -> string; + var_id_to_string : V.VarId.id -> string; + adt_field_names : + T.TypeDeclId.id -> T.VariantId.id option -> string list option; + } + + let value_to_etype_formatter (fmt : value_formatter) : PT.etype_formatter = + { + PT.r_to_string = PT.erased_region_to_string; + PT.type_var_id_to_string = fmt.type_var_id_to_string; + PT.type_decl_id_to_string = fmt.type_decl_id_to_string; + } + + let value_to_rtype_formatter (fmt : value_formatter) : PT.rtype_formatter = + { + PT.r_to_string = PT.region_to_string fmt.r_to_string; + PT.type_var_id_to_string = fmt.type_var_id_to_string; + PT.type_decl_id_to_string = fmt.type_decl_id_to_string; + } + + let value_to_stype_formatter (fmt : value_formatter) : PT.stype_formatter = + { + PT.r_to_string = PT.region_to_string fmt.rvar_to_string; + PT.type_var_id_to_string = fmt.type_var_id_to_string; + PT.type_decl_id_to_string = fmt.type_decl_id_to_string; + } + + let var_id_to_string (id : V.VarId.id) : string = + "var@" ^ V.VarId.to_string id + + let big_int_to_string (bi : V.big_int) : string = Z.to_string bi + + let scalar_value_to_string (sv : V.scalar_value) : string = + big_int_to_string sv.value ^ ": " ^ PT.integer_type_to_string sv.int_ty + + let constant_value_to_string (cv : V.constant_value) : string = + match cv with + | Scalar sv -> scalar_value_to_string sv + | Bool b -> Bool.to_string b + | Char c -> String.make 1 c + | String s -> s + + let symbolic_value_id_to_string (id : V.SymbolicValueId.id) : string = + "s@" ^ V.SymbolicValueId.to_string id + + let symbolic_value_to_string (fmt : PT.rtype_formatter) + (sv : V.symbolic_value) : string = + symbolic_value_id_to_string sv.sv_id ^ " : " ^ PT.rty_to_string fmt sv.sv_ty + + let symbolic_value_proj_to_string (fmt : value_formatter) + (sv : V.symbolic_value) (rty : T.rty) : string = + symbolic_value_id_to_string sv.sv_id + ^ " : " + ^ PT.ty_to_string (value_to_rtype_formatter fmt) sv.sv_ty + ^ " <: " + ^ PT.ty_to_string (value_to_rtype_formatter fmt) rty + + (* TODO: it may be a good idea to try to factorize this function with + * typed_avalue_to_string. At some point we had done it, because [typed_value] + * and [typed_avalue] were instances of the same general type [g_typed_value], + * but then we removed this general type because it proved to be a bad idea. *) + let rec typed_value_to_string (fmt : value_formatter) (v : V.typed_value) : + string = + let ty_fmt : PT.etype_formatter = value_to_etype_formatter fmt in + match v.value with + | Concrete cv -> constant_value_to_string cv + | Adt av -> ( + let field_values = + List.map (typed_value_to_string fmt) av.field_values + in + match v.ty with + | T.Adt (T.Tuple, _, _) -> + (* Tuple *) + "(" ^ String.concat ", " field_values ^ ")" + | T.Adt (T.AdtId def_id, _, _) -> + (* "Regular" ADT *) + let adt_ident = + match av.variant_id with + | Some vid -> fmt.adt_variant_to_string def_id vid + | None -> fmt.type_decl_id_to_string def_id + in + if List.length field_values > 0 then + match fmt.adt_field_names def_id av.V.variant_id with + | None -> + let field_values = String.concat ", " field_values in + adt_ident ^ " (" ^ field_values ^ ")" + | Some field_names -> + let field_values = List.combine field_names field_values in + let field_values = + List.map + (fun (field, value) -> field ^ " = " ^ value ^ ";") + field_values + in + let field_values = String.concat " " field_values in + adt_ident ^ " { " ^ field_values ^ " }" + else adt_ident + | T.Adt (T.Assumed aty, _, _) -> ( + (* Assumed type *) + match (aty, field_values) with + | Box, [ bv ] -> "@Box(" ^ bv ^ ")" + | Option, _ -> + if av.variant_id = Some T.option_some_id then + "@Option::Some(" + ^ Collections.List.to_cons_nil field_values + ^ ")" + else if av.variant_id = Some T.option_none_id then ( + assert (field_values = []); + "@Option::None") + else failwith "Unreachable" + | Vec, _ -> "@Vec[" ^ String.concat ", " field_values ^ "]" + | _ -> failwith "Inconsistent value") + | _ -> failwith "Inconsistent typed value") + | Bottom -> "⊥ : " ^ PT.ty_to_string ty_fmt v.ty + | Borrow bc -> borrow_content_to_string fmt bc + | Loan lc -> loan_content_to_string fmt lc + | Symbolic s -> symbolic_value_to_string (value_to_rtype_formatter fmt) s + + and borrow_content_to_string (fmt : value_formatter) (bc : V.borrow_content) : + string = + match bc with + | SharedBorrow (_, bid) -> "⌊shared@" ^ V.BorrowId.to_string bid ^ "⌋" + | MutBorrow (bid, tv) -> + "&mut@" ^ V.BorrowId.to_string bid ^ " (" + ^ typed_value_to_string fmt tv + ^ ")" + | InactivatedMutBorrow (_, bid) -> + "⌊inactivated_mut@" ^ V.BorrowId.to_string bid ^ "⌋" + + and loan_content_to_string (fmt : value_formatter) (lc : V.loan_content) : + string = + match lc with + | SharedLoan (loans, v) -> + let loans = V.BorrowId.Set.to_string None loans in + "@shared_loan(" ^ loans ^ ", " ^ typed_value_to_string fmt v ^ ")" + | MutLoan bid -> "⌊mut@" ^ V.BorrowId.to_string bid ^ "⌋" + + let abstract_shared_borrow_to_string (fmt : value_formatter) + (abs : V.abstract_shared_borrow) : string = + match abs with + | AsbBorrow bid -> V.BorrowId.to_string bid + | AsbProjReborrows (sv, rty) -> + "{" ^ symbolic_value_proj_to_string fmt sv rty ^ "}" + + let abstract_shared_borrows_to_string (fmt : value_formatter) + (abs : V.abstract_shared_borrows) : string = + "{" + ^ String.concat "," (List.map (abstract_shared_borrow_to_string fmt) abs) + ^ "}" + + let rec aproj_to_string (fmt : value_formatter) (pv : V.aproj) : string = + match pv with + | AProjLoans (sv, given_back) -> + let given_back = + if given_back = [] then "" + else + let given_back = List.map snd given_back in + let given_back = List.map (aproj_to_string fmt) given_back in + " (" ^ String.concat "," given_back ^ ") " + in + "⌊" + ^ symbolic_value_to_string (value_to_rtype_formatter fmt) sv + ^ given_back ^ "⌋" + | AProjBorrows (sv, rty) -> + "(" ^ symbolic_value_proj_to_string fmt sv rty ^ ")" + | AEndedProjLoans (_, given_back) -> + if given_back = [] then "_" + else + let given_back = List.map snd given_back in + let given_back = List.map (aproj_to_string fmt) given_back in + "ended_aproj_loans (" ^ String.concat "," given_back ^ ")" + | AEndedProjBorrows _mv -> "_" + | AIgnoredProjBorrows -> "_" + + let rec typed_avalue_to_string (fmt : value_formatter) (v : V.typed_avalue) : + string = + let ty_fmt : PT.rtype_formatter = value_to_rtype_formatter fmt in + match v.value with + | AConcrete cv -> constant_value_to_string cv + | AAdt av -> ( + let field_values = + List.map (typed_avalue_to_string fmt) av.field_values + in + match v.ty with + | T.Adt (T.Tuple, _, _) -> + (* Tuple *) + "(" ^ String.concat ", " field_values ^ ")" + | T.Adt (T.AdtId def_id, _, _) -> + (* "Regular" ADT *) + let adt_ident = + match av.variant_id with + | Some vid -> fmt.adt_variant_to_string def_id vid + | None -> fmt.type_decl_id_to_string def_id + in + if List.length field_values > 0 then + match fmt.adt_field_names def_id av.V.variant_id with + | None -> + let field_values = String.concat ", " field_values in + adt_ident ^ " (" ^ field_values ^ ")" + | Some field_names -> + let field_values = List.combine field_names field_values in + let field_values = + List.map + (fun (field, value) -> field ^ " = " ^ value ^ ";") + field_values + in + let field_values = String.concat " " field_values in + adt_ident ^ " { " ^ field_values ^ " }" + else adt_ident + | T.Adt (T.Assumed aty, _, _) -> ( + (* Assumed type *) + match (aty, field_values) with + | Box, [ bv ] -> "@Box(" ^ bv ^ ")" + | _ -> failwith "Inconsistent value") + | _ -> failwith "Inconsistent typed value") + | ABottom -> "⊥ : " ^ PT.ty_to_string ty_fmt v.ty + | ABorrow bc -> aborrow_content_to_string fmt bc + | ALoan lc -> aloan_content_to_string fmt lc + | ASymbolic s -> aproj_to_string fmt s + | AIgnored -> "_" + + and aloan_content_to_string (fmt : value_formatter) (lc : V.aloan_content) : + string = + match lc with + | AMutLoan (bid, av) -> + "⌊mut@" ^ V.BorrowId.to_string bid ^ ", " + ^ typed_avalue_to_string fmt av + ^ "⌋" + | ASharedLoan (loans, v, av) -> + let loans = V.BorrowId.Set.to_string None loans in + "@shared_loan(" ^ loans ^ ", " + ^ typed_value_to_string fmt v + ^ ", " + ^ typed_avalue_to_string fmt av + ^ ")" + | AEndedMutLoan ml -> + "@ended_mut_loan{" + ^ typed_avalue_to_string fmt ml.child + ^ "; " + ^ typed_avalue_to_string fmt ml.given_back + ^ " }" + | AEndedSharedLoan (v, av) -> + "@ended_shared_loan(" + ^ typed_value_to_string fmt v + ^ ", " + ^ typed_avalue_to_string fmt av + ^ ")" + | AIgnoredMutLoan (bid, av) -> + "@ignored_mut_loan(" ^ V.BorrowId.to_string bid ^ ", " + ^ typed_avalue_to_string fmt av + ^ ")" + | AEndedIgnoredMutLoan ml -> + "@ended_ignored_mut_loan{ " + ^ typed_avalue_to_string fmt ml.child + ^ "; " + ^ typed_avalue_to_string fmt ml.given_back + ^ "}" + | AIgnoredSharedLoan sl -> + "@ignored_shared_loan(" ^ typed_avalue_to_string fmt sl ^ ")" + + and aborrow_content_to_string (fmt : value_formatter) (bc : V.aborrow_content) + : string = + match bc with + | AMutBorrow (_, bid, av) -> + "&mut@" ^ V.BorrowId.to_string bid ^ " (" + ^ typed_avalue_to_string fmt av + ^ ")" + | ASharedBorrow bid -> "⌊shared@" ^ V.BorrowId.to_string bid ^ "⌋" + | AIgnoredMutBorrow (opt_bid, av) -> + "@ignored_mut_borrow(" + ^ option_to_string V.BorrowId.to_string opt_bid + ^ ", " + ^ typed_avalue_to_string fmt av + ^ ")" + | AEndedMutBorrow (_mv, child) -> + "@ended_mut_borrow(" ^ typed_avalue_to_string fmt child ^ ")" + | AEndedIgnoredMutBorrow + { child; given_back_loans_proj; given_back_meta = _ } -> + "@ended_ignored_mut_borrow{ " + ^ typed_avalue_to_string fmt child + ^ "; " + ^ typed_avalue_to_string fmt given_back_loans_proj + ^ ")" + | AEndedSharedBorrow -> "@ended_shared_borrow" + | AProjSharedBorrow sb -> + "@ignored_shared_borrow(" + ^ abstract_shared_borrows_to_string fmt sb + ^ ")" + + let abs_to_string (fmt : value_formatter) (indent : string) + (indent_incr : string) (abs : V.abs) : string = + let indent2 = indent ^ indent_incr in + let avs = + List.map (fun av -> indent2 ^ typed_avalue_to_string fmt av) abs.avalues + in + let avs = String.concat ",\n" avs in + indent ^ "abs@" + ^ V.AbstractionId.to_string abs.abs_id + ^ "{parents=" + ^ V.AbstractionId.Set.to_string None abs.parents + ^ "}" ^ "{regions=" + ^ T.RegionId.Set.to_string None abs.regions + ^ "}" ^ " {\n" ^ avs ^ "\n" ^ indent ^ "}" +end + +module PV = Values (* local module *) + +(** Pretty-printing for contexts *) +module Contexts = struct + let binder_to_string (bv : C.binder) : string = + match bv.name with + | None -> PV.var_id_to_string bv.index + | Some name -> name + + let env_elem_to_string (fmt : PV.value_formatter) (indent : string) + (indent_incr : string) (ev : C.env_elem) : string = + match ev with + | Var (var, tv) -> + let bv = + match var with Some var -> binder_to_string var | None -> "_" + in + indent ^ bv ^ " -> " ^ PV.typed_value_to_string fmt tv ^ " ;" + | Abs abs -> PV.abs_to_string fmt indent indent_incr abs + | Frame -> failwith "Can't print a Frame element" + + let opt_env_elem_to_string (fmt : PV.value_formatter) (indent : string) + (indent_incr : string) (ev : C.env_elem option) : string = + match ev with + | None -> indent ^ "..." + | Some ev -> env_elem_to_string fmt indent indent_incr ev + + (** Filters "dummy" bindings from an environment, to gain space and clarity/ + See [env_to_string]. *) + let filter_env (env : C.env) : C.env_elem option list = + (* We filter: + * - non-dummy bindings which point to ⊥ + * - dummy bindings which don't contain loans nor borrows + * Note that the first case can sometimes be confusing: we may try to improve + * it... + *) + let filter_elem (ev : C.env_elem) : C.env_elem option = + match ev with + | Var (Some _, tv) -> + (* Not a dummy binding: check if the value is ⊥ *) + if VU.is_bottom tv.value then None else Some ev + | Var (None, tv) -> + (* Dummy binding: check if the value contains borrows or loans *) + if VU.borrows_in_value tv || VU.loans_in_value tv then Some ev + else None + | _ -> Some ev + in + let env = List.map filter_elem env in + (* We collapse groups of filtered values - so that we can print one + * single "..." for a whole group of filtered values *) + let rec group_filtered (env : C.env_elem option list) : + C.env_elem option list = + match env with + | [] -> [] + | None :: None :: env -> group_filtered (None :: env) + | x :: env -> x :: group_filtered env + in + group_filtered env + + (** Environments can have a lot of dummy or uninitialized values: [filter] + allows to filter them when printing, replacing groups of such bindings with + "..." to gain space and clarity. + *) + let env_to_string (filter : bool) (fmt : PV.value_formatter) (env : C.env) : + string = + let env = + if filter then filter_env env else List.map (fun ev -> Some ev) env + in + "{\n" + ^ String.concat "\n" + (List.map (fun ev -> opt_env_elem_to_string fmt " " " " ev) env) + ^ "\n}" + + type ctx_formatter = PV.value_formatter + + let ctx_to_etype_formatter (fmt : ctx_formatter) : PT.etype_formatter = + PV.value_to_etype_formatter fmt + + let ctx_to_rtype_formatter (fmt : ctx_formatter) : PT.rtype_formatter = + PV.value_to_rtype_formatter fmt + + let type_ctx_to_adt_variant_to_string_fun + (ctx : T.type_decl T.TypeDeclId.Map.t) : + T.TypeDeclId.id -> T.VariantId.id -> string = + fun def_id variant_id -> + let def = T.TypeDeclId.Map.find def_id ctx in + match def.kind with + | Struct _ | Opaque -> failwith "Unreachable" + | Enum variants -> + let variant = T.VariantId.nth variants variant_id in + name_to_string def.name ^ "::" ^ variant.variant_name + + let type_ctx_to_adt_field_names_fun (ctx : T.type_decl T.TypeDeclId.Map.t) : + T.TypeDeclId.id -> T.VariantId.id option -> string list option = + fun def_id opt_variant_id -> + let def = T.TypeDeclId.Map.find def_id ctx in + let fields = TU.type_decl_get_fields def opt_variant_id in + (* There are two cases: either all the fields have names, or none of them + * has names *) + let has_names = + List.exists (fun f -> Option.is_some f.T.field_name) fields + in + if has_names then + let fields = List.map (fun f -> Option.get f.T.field_name) fields in + Some fields + else None + + let eval_ctx_to_ctx_formatter (ctx : C.eval_ctx) : ctx_formatter = + (* We shouldn't use rvar_to_string *) + let rvar_to_string _r = failwith "Unexpected use of rvar_to_string" in + let r_to_string r = PT.region_id_to_string r in + + let type_var_id_to_string vid = + let v = C.lookup_type_var ctx vid in + v.name + in + let type_decl_id_to_string def_id = + let def = C.ctx_lookup_type_decl ctx def_id in + name_to_string def.name + in + let adt_variant_to_string = + type_ctx_to_adt_variant_to_string_fun ctx.type_context.type_decls + in + let var_id_to_string vid = + let bv = C.ctx_lookup_binder ctx vid in + binder_to_string bv + in + let adt_field_names = + type_ctx_to_adt_field_names_fun ctx.type_context.type_decls + in + { + rvar_to_string; + r_to_string; + type_var_id_to_string; + type_decl_id_to_string; + adt_variant_to_string; + var_id_to_string; + adt_field_names; + } + + (** Split an [env] at every occurrence of [Frame], eliminating those elements. + Also reorders the frames and the values in the frames according to the + following order: + * frames: from the current frame to the first pushed (oldest frame) + * values: from the first pushed (oldest) to the last pushed + *) + let split_env_according_to_frames (env : C.env) : C.env list = + let rec split_aux (frames : C.env list) (curr_frame : C.env) (env : C.env) = + match env with + | [] -> + if List.length curr_frame > 0 then curr_frame :: frames else frames + | Frame :: env' -> split_aux (curr_frame :: frames) [] env' + | ev :: env' -> split_aux frames (ev :: curr_frame) env' + in + let frames = split_aux [] [] env in + frames + + let eval_ctx_to_string (ctx : C.eval_ctx) : string = + let fmt = eval_ctx_to_ctx_formatter ctx in + let ended_regions = T.RegionId.Set.to_string None ctx.ended_regions in + let frames = split_env_according_to_frames ctx.env in + let num_frames = List.length frames in + let frames = + List.mapi + (fun i f -> + let num_bindings = ref 0 in + let num_dummies = ref 0 in + let num_abs = ref 0 in + List.iter + (fun ev -> + match ev with + | C.Var (None, _) -> num_dummies := !num_abs + 1 + | C.Var (Some _, _) -> num_bindings := !num_bindings + 1 + | C.Abs _ -> num_abs := !num_abs + 1 + | _ -> raise (Failure "Unreachable")) + f; + "\n# Frame " ^ string_of_int i ^ ":" ^ "\n- locals: " + ^ string_of_int !num_bindings + ^ "\n- dummy bindings: " ^ string_of_int !num_dummies + ^ "\n- abstractions: " ^ string_of_int !num_abs ^ "\n" + ^ env_to_string true fmt f ^ "\n") + frames + in + "# Ended regions: " ^ ended_regions ^ "\n" ^ "# " ^ string_of_int num_frames + ^ " frame(s)\n" ^ String.concat "" frames +end + +module PC = Contexts (* local module *) + +(** Pretty-printing for contexts (generic functions) *) +module LlbcAst = struct + let var_to_string (var : A.var) : string = + match var.name with + | None -> V.VarId.to_string var.index + | Some name -> name + + type ast_formatter = { + rvar_to_string : T.RegionVarId.id -> string; + r_to_string : T.RegionId.id -> string; + type_var_id_to_string : T.TypeVarId.id -> string; + type_decl_id_to_string : T.TypeDeclId.id -> string; + adt_variant_to_string : T.TypeDeclId.id -> T.VariantId.id -> string; + adt_field_to_string : + T.TypeDeclId.id -> T.VariantId.id option -> T.FieldId.id -> string option; + var_id_to_string : V.VarId.id -> string; + adt_field_names : + T.TypeDeclId.id -> T.VariantId.id option -> string list option; + fun_decl_id_to_string : A.FunDeclId.id -> string; + global_decl_id_to_string : A.GlobalDeclId.id -> string; + } + + let ast_to_ctx_formatter (fmt : ast_formatter) : PC.ctx_formatter = + { + PV.rvar_to_string = fmt.rvar_to_string; + PV.r_to_string = fmt.r_to_string; + PV.type_var_id_to_string = fmt.type_var_id_to_string; + PV.type_decl_id_to_string = fmt.type_decl_id_to_string; + PV.adt_variant_to_string = fmt.adt_variant_to_string; + PV.var_id_to_string = fmt.var_id_to_string; + PV.adt_field_names = fmt.adt_field_names; + } + + let ast_to_value_formatter (fmt : ast_formatter) : PV.value_formatter = + ast_to_ctx_formatter fmt + + let ast_to_etype_formatter (fmt : ast_formatter) : PT.etype_formatter = + { + PT.r_to_string = PT.erased_region_to_string; + PT.type_var_id_to_string = fmt.type_var_id_to_string; + PT.type_decl_id_to_string = fmt.type_decl_id_to_string; + } + + let ast_to_rtype_formatter (fmt : ast_formatter) : PT.rtype_formatter = + { + PT.r_to_string = PT.region_to_string fmt.r_to_string; + PT.type_var_id_to_string = fmt.type_var_id_to_string; + PT.type_decl_id_to_string = fmt.type_decl_id_to_string; + } + + let ast_to_stype_formatter (fmt : ast_formatter) : PT.stype_formatter = + { + PT.r_to_string = PT.region_to_string fmt.rvar_to_string; + PT.type_var_id_to_string = fmt.type_var_id_to_string; + PT.type_decl_id_to_string = fmt.type_decl_id_to_string; + } + + let type_ctx_to_adt_field_to_string_fun (ctx : T.type_decl T.TypeDeclId.Map.t) + : + T.TypeDeclId.id -> T.VariantId.id option -> T.FieldId.id -> string option + = + fun def_id opt_variant_id field_id -> + let def = T.TypeDeclId.Map.find def_id ctx in + let fields = TU.type_decl_get_fields def opt_variant_id in + let field = T.FieldId.nth fields field_id in + field.T.field_name + + let eval_ctx_to_ast_formatter (ctx : C.eval_ctx) : ast_formatter = + let ctx_fmt = PC.eval_ctx_to_ctx_formatter ctx in + let adt_field_to_string = + type_ctx_to_adt_field_to_string_fun ctx.type_context.type_decls + in + let fun_decl_id_to_string def_id = + let def = C.ctx_lookup_fun_decl ctx def_id in + fun_name_to_string def.name + in + let global_decl_id_to_string def_id = + let def = C.ctx_lookup_global_decl ctx def_id in + global_name_to_string def.name + in + { + rvar_to_string = ctx_fmt.PV.rvar_to_string; + r_to_string = ctx_fmt.PV.r_to_string; + type_var_id_to_string = ctx_fmt.PV.type_var_id_to_string; + type_decl_id_to_string = ctx_fmt.PV.type_decl_id_to_string; + adt_variant_to_string = ctx_fmt.PV.adt_variant_to_string; + var_id_to_string = ctx_fmt.PV.var_id_to_string; + adt_field_names = ctx_fmt.PV.adt_field_names; + adt_field_to_string; + fun_decl_id_to_string; + global_decl_id_to_string; + } + + let fun_decl_to_ast_formatter (type_decls : T.type_decl T.TypeDeclId.Map.t) + (fun_decls : A.fun_decl A.FunDeclId.Map.t) + (global_decls : A.global_decl A.GlobalDeclId.Map.t) (fdef : A.fun_decl) : + ast_formatter = + let rvar_to_string r = + let rvar = T.RegionVarId.nth fdef.signature.region_params r in + PT.region_var_to_string rvar + in + let r_to_string r = PT.region_id_to_string r in + + let type_var_id_to_string vid = + let var = T.TypeVarId.nth fdef.signature.type_params vid in + PT.type_var_to_string var + in + let type_decl_id_to_string def_id = + let def = T.TypeDeclId.Map.find def_id type_decls in + name_to_string def.name + in + let adt_variant_to_string = + PC.type_ctx_to_adt_variant_to_string_fun type_decls + in + let var_id_to_string vid = + let var = V.VarId.nth (Option.get fdef.body).locals vid in + var_to_string var + in + let adt_field_names = PC.type_ctx_to_adt_field_names_fun type_decls in + let adt_field_to_string = type_ctx_to_adt_field_to_string_fun type_decls in + let fun_decl_id_to_string def_id = + let def = A.FunDeclId.Map.find def_id fun_decls in + fun_name_to_string def.name + in + let global_decl_id_to_string def_id = + let def = A.GlobalDeclId.Map.find def_id global_decls in + global_name_to_string def.name + in + { + rvar_to_string; + r_to_string; + type_var_id_to_string; + type_decl_id_to_string; + adt_variant_to_string; + var_id_to_string; + adt_field_names; + adt_field_to_string; + fun_decl_id_to_string; + global_decl_id_to_string; + } + + let rec projection_to_string (fmt : ast_formatter) (inside : string) + (p : E.projection) : string = + match p with + | [] -> inside + | pe :: p' -> ( + let s = projection_to_string fmt inside p' in + match pe with + | E.Deref -> "*(" ^ s ^ ")" + | E.DerefBox -> "deref_box(" ^ s ^ ")" + | E.Field (E.ProjOption variant_id, fid) -> + assert (variant_id = T.option_some_id); + assert (fid = T.FieldId.zero); + "(" ^ s ^ " as Option::Some)." ^ T.FieldId.to_string fid + | E.Field (E.ProjTuple _, fid) -> + "(" ^ s ^ ")." ^ T.FieldId.to_string fid + | E.Field (E.ProjAdt (adt_id, opt_variant_id), fid) -> ( + let field_name = + match fmt.adt_field_to_string adt_id opt_variant_id fid with + | Some field_name -> field_name + | None -> T.FieldId.to_string fid + in + match opt_variant_id with + | None -> "(" ^ s ^ ")." ^ field_name + | Some variant_id -> + let variant_name = + fmt.adt_variant_to_string adt_id variant_id + in + "(" ^ s ^ " as " ^ variant_name ^ ")." ^ field_name)) + + let place_to_string (fmt : ast_formatter) (p : E.place) : string = + let var = fmt.var_id_to_string p.E.var_id in + projection_to_string fmt var p.E.projection + + let unop_to_string (unop : E.unop) : string = + match unop with + | E.Not -> "¬" + | E.Neg -> "-" + | E.Cast (src, tgt) -> + "cast<" + ^ PT.integer_type_to_string src + ^ "," + ^ PT.integer_type_to_string tgt + ^ ">" + + let binop_to_string (binop : E.binop) : string = + match binop with + | E.BitXor -> "^" + | E.BitAnd -> "&" + | E.BitOr -> "|" + | E.Eq -> "==" + | E.Lt -> "<" + | E.Le -> "<=" + | E.Ne -> "!=" + | E.Ge -> ">=" + | E.Gt -> ">" + | E.Div -> "/" + | E.Rem -> "%" + | E.Add -> "+" + | E.Sub -> "-" + | E.Mul -> "*" + | E.Shl -> "<<" + | E.Shr -> ">>" + + let operand_to_string (fmt : ast_formatter) (op : E.operand) : string = + match op with + | E.Copy p -> "copy " ^ place_to_string fmt p + | E.Move p -> "move " ^ place_to_string fmt p + | E.Constant (ty, cv) -> + "(" + ^ PV.constant_value_to_string cv + ^ " : " + ^ PT.ety_to_string (ast_to_etype_formatter fmt) ty + ^ ")" + + let rvalue_to_string (fmt : ast_formatter) (rv : E.rvalue) : string = + match rv with + | E.Use op -> operand_to_string fmt op + | E.Ref (p, bk) -> ( + let p = place_to_string fmt p in + match bk with + | E.Shared -> "&" ^ p + | E.Mut -> "&mut " ^ p + | E.TwoPhaseMut -> "&two-phase " ^ p) + | E.UnaryOp (unop, op) -> + unop_to_string unop ^ " " ^ operand_to_string fmt op + | E.BinaryOp (binop, op1, op2) -> + operand_to_string fmt op1 ^ " " ^ binop_to_string binop ^ " " + ^ operand_to_string fmt op2 + | E.Discriminant p -> "discriminant(" ^ place_to_string fmt p ^ ")" + | E.Aggregate (akind, ops) -> ( + let ops = List.map (operand_to_string fmt) ops in + match akind with + | E.AggregatedTuple -> "(" ^ String.concat ", " ops ^ ")" + | E.AggregatedOption (variant_id, _ty) -> + if variant_id == T.option_none_id then ( + assert (ops == []); + "@Option::None") + else if variant_id == T.option_some_id then ( + assert (List.length ops == 1); + let op = List.hd ops in + "@Option::Some(" ^ op ^ ")") + else raise (Failure "Unreachable") + | E.AggregatedAdt (def_id, opt_variant_id, _regions, _types) -> + let adt_name = fmt.type_decl_id_to_string def_id in + let variant_name = + match opt_variant_id with + | None -> adt_name + | Some variant_id -> + adt_name ^ "::" ^ fmt.adt_variant_to_string def_id variant_id + in + let fields = + match fmt.adt_field_names def_id opt_variant_id with + | None -> "(" ^ String.concat ", " ops ^ ")" + | Some field_names -> + let fields = List.combine field_names ops in + let fields = + List.map + (fun (field, value) -> field ^ " = " ^ value ^ ";") + fields + in + let fields = String.concat " " fields in + "{ " ^ fields ^ " }" + in + variant_name ^ " " ^ fields) + + let rec statement_to_string (fmt : ast_formatter) (indent : string) + (indent_incr : string) (st : A.statement) : string = + raw_statement_to_string fmt indent indent_incr st.content + + and raw_statement_to_string (fmt : ast_formatter) (indent : string) + (indent_incr : string) (st : A.raw_statement) : string = + match st with + | A.Assign (p, rv) -> + indent ^ place_to_string fmt p ^ " := " ^ rvalue_to_string fmt rv + | A.AssignGlobal { dst; global } -> + indent ^ fmt.var_id_to_string dst ^ " := global " + ^ fmt.global_decl_id_to_string global + | A.FakeRead p -> indent ^ "fake_read " ^ place_to_string fmt p + | A.SetDiscriminant (p, variant_id) -> + (* TODO: improve this to lookup the variant name by using the def id *) + indent ^ "set_discriminant(" ^ place_to_string fmt p ^ ", " + ^ T.VariantId.to_string variant_id + ^ ")" + | A.Drop p -> indent ^ "drop " ^ place_to_string fmt p + | A.Assert a -> + let cond = operand_to_string fmt a.A.cond in + if a.A.expected then indent ^ "assert(" ^ cond ^ ")" + else indent ^ "assert(¬" ^ cond ^ ")" + | A.Call call -> + let ty_fmt = ast_to_etype_formatter fmt in + let t_params = + if List.length call.A.type_args > 0 then + "<" + ^ String.concat "," + (List.map (PT.ty_to_string ty_fmt) call.A.type_args) + ^ ">" + else "" + in + let args = List.map (operand_to_string fmt) call.A.args in + let args = "(" ^ String.concat ", " args ^ ")" in + let name_args = + match call.A.func with + | A.Regular fid -> fmt.fun_decl_id_to_string fid ^ t_params + | A.Assumed fid -> ( + match fid with + | A.Replace -> "core::mem::replace" ^ t_params + | A.BoxNew -> "alloc::boxed::Box" ^ t_params ^ "::new" + | A.BoxDeref -> + "core::ops::deref::Deref::deref" + | A.BoxDerefMut -> + "core::ops::deref::DerefMut" ^ t_params ^ "::deref_mut" + | A.BoxFree -> "alloc::alloc::box_free" ^ t_params + | A.VecNew -> "alloc::vec::Vec" ^ t_params ^ "::new" + | A.VecPush -> "alloc::vec::Vec" ^ t_params ^ "::push" + | A.VecInsert -> "alloc::vec::Vec" ^ t_params ^ "::insert" + | A.VecLen -> "alloc::vec::Vec" ^ t_params ^ "::len" + | A.VecIndex -> + "core::ops::index::Index::index" + | A.VecIndexMut -> + "core::ops::index::IndexMut::index_mut") + in + let dest = place_to_string fmt call.A.dest in + indent ^ dest ^ " := move " ^ name_args ^ args + | A.Panic -> indent ^ "panic" + | A.Return -> indent ^ "return" + | A.Break i -> indent ^ "break " ^ string_of_int i + | A.Continue i -> indent ^ "continue " ^ string_of_int i + | A.Nop -> indent ^ "nop" + | A.Sequence (st1, st2) -> + statement_to_string fmt indent indent_incr st1 + ^ ";\n" + ^ statement_to_string fmt indent indent_incr st2 + | A.Switch (op, tgts) -> ( + let op = operand_to_string fmt op in + match tgts with + | A.If (true_st, false_st) -> + let inner_indent = indent ^ indent_incr in + let inner_to_string = + statement_to_string fmt inner_indent indent_incr + in + let true_st = inner_to_string true_st in + let false_st = inner_to_string false_st in + indent ^ "if (" ^ op ^ ") {\n" ^ true_st ^ "\n" ^ indent ^ "}\n" + ^ indent ^ "else {\n" ^ false_st ^ "\n" ^ indent ^ "}" + | A.SwitchInt (_ty, branches, otherwise) -> + let indent1 = indent ^ indent_incr in + let indent2 = indent1 ^ indent_incr in + let inner_to_string2 = + statement_to_string fmt indent2 indent_incr + in + let branches = + List.map + (fun (svl, be) -> + let svl = + List.map (fun sv -> "| " ^ PV.scalar_value_to_string sv) svl + in + let svl = String.concat " " svl in + indent1 ^ svl ^ " => {\n" ^ inner_to_string2 be ^ "\n" + ^ indent1 ^ "}") + branches + in + let branches = String.concat "\n" branches in + let branches = + branches ^ "\n" ^ indent1 ^ "_ => {\n" + ^ inner_to_string2 otherwise ^ "\n" ^ indent1 ^ "}" + in + indent ^ "switch (" ^ op ^ ") {\n" ^ branches ^ "\n" ^ indent ^ "}") + | A.Loop loop_st -> + indent ^ "loop {\n" + ^ statement_to_string fmt (indent ^ indent_incr) indent_incr loop_st + ^ "\n" ^ indent ^ "}" + + let var_to_string (v : A.var) : string = + match v.name with None -> PV.var_id_to_string v.index | Some name -> name + + let fun_decl_to_string (fmt : ast_formatter) (indent : string) + (indent_incr : string) (def : A.fun_decl) : string = + let sty_fmt = ast_to_stype_formatter fmt in + let sty_to_string = PT.sty_to_string sty_fmt in + let ety_fmt = ast_to_etype_formatter fmt in + let ety_to_string = PT.ety_to_string ety_fmt in + let sg = def.signature in + + (* Function name *) + let name = fun_name_to_string def.A.name in + + (* Region/type parameters *) + let regions = sg.region_params in + let types = sg.type_params in + let params = + if List.length regions + List.length types = 0 then "" + else + let regions = List.map PT.region_var_to_string regions in + let types = List.map PT.type_var_to_string types in + "<" ^ String.concat "," (List.append regions types) ^ ">" + in + + (* Return type *) + let ret_ty = sg.output in + let ret_ty = + if TU.ty_is_unit ret_ty then "" else " -> " ^ sty_to_string ret_ty + in + + (* We print the declaration differently if it is opaque (no body) or transparent + * (we have access to a body) *) + match def.body with + | None -> + (* Arguments *) + let input_tys = sg.inputs in + let args = List.map sty_to_string input_tys in + let args = String.concat ", " args in + + (* Put everything together *) + indent ^ "opaque fn " ^ name ^ params ^ "(" ^ args ^ ")" ^ ret_ty + | Some body -> + (* Arguments *) + let inputs = List.tl body.locals in + let inputs, _aux_locals = + Collections.List.split_at inputs body.arg_count + in + let args = List.combine inputs sg.inputs in + let args = + List.map + (fun (var, rty) -> var_to_string var ^ " : " ^ sty_to_string rty) + args + in + let args = String.concat ", " args in + + (* All the locals (with erased regions) *) + let locals = + List.map + (fun var -> + indent ^ indent_incr ^ var_to_string var ^ " : " + ^ ety_to_string var.var_ty ^ ";") + body.locals + in + let locals = String.concat "\n" locals in + + (* Body *) + let body = + statement_to_string fmt (indent ^ indent_incr) indent_incr body.body + in + + (* Put everything together *) + indent ^ "fn " ^ name ^ params ^ "(" ^ args ^ ")" ^ ret_ty ^ " {\n" + ^ locals ^ "\n\n" ^ body ^ "\n" ^ indent ^ "}" +end + +module PA = LlbcAst (* local module *) + +(** Pretty-printing for ASTs (functions based on a definition context) *) +module Module = struct + (** This function pretty-prints a type definition by using a definition + context *) + let type_decl_to_string (type_context : T.type_decl T.TypeDeclId.Map.t) + (def : T.type_decl) : string = + let type_decl_id_to_string (id : T.TypeDeclId.id) : string = + let def = T.TypeDeclId.Map.find id type_context in + name_to_string def.name + in + PT.type_decl_to_string type_decl_id_to_string def + + (** Generate an [ast_formatter] by using a definition context in combination + with the variables local to a function's definition *) + let def_ctx_to_ast_formatter (type_context : T.type_decl T.TypeDeclId.Map.t) + (fun_context : A.fun_decl A.FunDeclId.Map.t) + (global_context : A.global_decl A.GlobalDeclId.Map.t) (def : A.fun_decl) : + PA.ast_formatter = + let rvar_to_string vid = + let var = T.RegionVarId.nth def.signature.region_params vid in + PT.region_var_to_string var + in + let r_to_string vid = + (* TODO: we might want something more informative *) + PT.region_id_to_string vid + in + let type_var_id_to_string vid = + let var = T.TypeVarId.nth def.signature.type_params vid in + PT.type_var_to_string var + in + let type_decl_id_to_string def_id = + let def = T.TypeDeclId.Map.find def_id type_context in + name_to_string def.name + in + let fun_decl_id_to_string def_id = + let def = A.FunDeclId.Map.find def_id fun_context in + fun_name_to_string def.name + in + let global_decl_id_to_string def_id = + let def = A.GlobalDeclId.Map.find def_id global_context in + global_name_to_string def.name + in + let var_id_to_string vid = + let var = V.VarId.nth (Option.get def.body).locals vid in + PA.var_to_string var + in + let adt_variant_to_string = + PC.type_ctx_to_adt_variant_to_string_fun type_context + in + let adt_field_to_string = + PA.type_ctx_to_adt_field_to_string_fun type_context + in + let adt_field_names = PC.type_ctx_to_adt_field_names_fun type_context in + { + rvar_to_string; + r_to_string; + type_var_id_to_string; + type_decl_id_to_string; + adt_variant_to_string; + adt_field_to_string; + var_id_to_string; + adt_field_names; + fun_decl_id_to_string; + global_decl_id_to_string; + } + + (** This function pretty-prints a function definition by using a definition + context *) + let fun_decl_to_string (type_context : T.type_decl T.TypeDeclId.Map.t) + (fun_context : A.fun_decl A.FunDeclId.Map.t) + (global_context : A.global_decl A.GlobalDeclId.Map.t) (def : A.fun_decl) : + string = + let fmt = + def_ctx_to_ast_formatter type_context fun_context global_context def + in + PA.fun_decl_to_string fmt "" " " def + + let module_to_string (m : Crates.llbc_crate) : string = + let types_defs_map, funs_defs_map, globals_defs_map = + Crates.compute_defs_maps m + in + + (* The types *) + let type_decls = + List.map (type_decl_to_string types_defs_map) m.Crates.types + in + + (* The functions *) + let fun_decls = + List.map + (fun_decl_to_string types_defs_map funs_defs_map globals_defs_map) + m.Crates.functions + in + + (* Put everything together *) + let all_defs = List.append type_decls fun_decls in + String.concat "\n\n" all_defs +end + +(** Pretty-printing for LLBC ASTs (functions based on an evaluation context) *) +module EvalCtxLlbcAst = struct + let ety_to_string (ctx : C.eval_ctx) (t : T.ety) : string = + let fmt = PC.eval_ctx_to_ctx_formatter ctx in + let fmt = PC.ctx_to_etype_formatter fmt in + PT.ety_to_string fmt t + + let rty_to_string (ctx : C.eval_ctx) (t : T.rty) : string = + let fmt = PC.eval_ctx_to_ctx_formatter ctx in + let fmt = PC.ctx_to_rtype_formatter fmt in + PT.rty_to_string fmt t + + let borrow_content_to_string (ctx : C.eval_ctx) (bc : V.borrow_content) : + string = + let fmt = PC.eval_ctx_to_ctx_formatter ctx in + PV.borrow_content_to_string fmt bc + + let loan_content_to_string (ctx : C.eval_ctx) (lc : V.loan_content) : string = + let fmt = PC.eval_ctx_to_ctx_formatter ctx in + PV.loan_content_to_string fmt lc + + let aborrow_content_to_string (ctx : C.eval_ctx) (bc : V.aborrow_content) : + string = + let fmt = PC.eval_ctx_to_ctx_formatter ctx in + PV.aborrow_content_to_string fmt bc + + let aloan_content_to_string (ctx : C.eval_ctx) (lc : V.aloan_content) : string + = + let fmt = PC.eval_ctx_to_ctx_formatter ctx in + PV.aloan_content_to_string fmt lc + + let aproj_to_string (ctx : C.eval_ctx) (p : V.aproj) : string = + let fmt = PC.eval_ctx_to_ctx_formatter ctx in + PV.aproj_to_string fmt p + + let symbolic_value_to_string (ctx : C.eval_ctx) (sv : V.symbolic_value) : + string = + let fmt = PC.eval_ctx_to_ctx_formatter ctx in + let fmt = PC.ctx_to_rtype_formatter fmt in + PV.symbolic_value_to_string fmt sv + + let typed_value_to_string (ctx : C.eval_ctx) (v : V.typed_value) : string = + let fmt = PC.eval_ctx_to_ctx_formatter ctx in + PV.typed_value_to_string fmt v + + let typed_avalue_to_string (ctx : C.eval_ctx) (v : V.typed_avalue) : string = + let fmt = PC.eval_ctx_to_ctx_formatter ctx in + PV.typed_avalue_to_string fmt v + + let place_to_string (ctx : C.eval_ctx) (op : E.place) : string = + let fmt = PA.eval_ctx_to_ast_formatter ctx in + PA.place_to_string fmt op + + let operand_to_string (ctx : C.eval_ctx) (op : E.operand) : string = + let fmt = PA.eval_ctx_to_ast_formatter ctx in + PA.operand_to_string fmt op + + let statement_to_string (ctx : C.eval_ctx) (indent : string) + (indent_incr : string) (e : A.statement) : string = + let fmt = PA.eval_ctx_to_ast_formatter ctx in + PA.statement_to_string fmt indent indent_incr e +end diff --git a/compiler/PrintPure.ml b/compiler/PrintPure.ml new file mode 100644 index 00000000..a9e42f6c --- /dev/null +++ b/compiler/PrintPure.ml @@ -0,0 +1,594 @@ +(** This module defines printing functions for the types defined in Pure.ml *) + +open Pure +open PureUtils + +type type_formatter = { + type_var_id_to_string : TypeVarId.id -> string; + type_decl_id_to_string : TypeDeclId.id -> string; +} + +type value_formatter = { + type_var_id_to_string : TypeVarId.id -> string; + type_decl_id_to_string : TypeDeclId.id -> string; + adt_variant_to_string : TypeDeclId.id -> VariantId.id -> string; + var_id_to_string : VarId.id -> string; + adt_field_names : TypeDeclId.id -> VariantId.id option -> string list option; +} + +let value_to_type_formatter (fmt : value_formatter) : type_formatter = + { + type_var_id_to_string = fmt.type_var_id_to_string; + type_decl_id_to_string = fmt.type_decl_id_to_string; + } + +(* TODO: we need to store which variables we have encountered so far, and + remove [var_id_to_string]. +*) +type ast_formatter = { + type_var_id_to_string : TypeVarId.id -> string; + type_decl_id_to_string : TypeDeclId.id -> string; + adt_variant_to_string : TypeDeclId.id -> VariantId.id -> string; + var_id_to_string : VarId.id -> string; + adt_field_to_string : + TypeDeclId.id -> VariantId.id option -> FieldId.id -> string option; + adt_field_names : TypeDeclId.id -> VariantId.id option -> string list option; + fun_decl_id_to_string : FunDeclId.id -> string; + global_decl_id_to_string : GlobalDeclId.id -> string; +} + +let ast_to_value_formatter (fmt : ast_formatter) : value_formatter = + { + type_var_id_to_string = fmt.type_var_id_to_string; + type_decl_id_to_string = fmt.type_decl_id_to_string; + adt_variant_to_string = fmt.adt_variant_to_string; + var_id_to_string = fmt.var_id_to_string; + adt_field_names = fmt.adt_field_names; + } + +let ast_to_type_formatter (fmt : ast_formatter) : type_formatter = + let fmt = ast_to_value_formatter fmt in + value_to_type_formatter fmt + +let name_to_string = Print.name_to_string +let fun_name_to_string = Print.fun_name_to_string +let global_name_to_string = Print.global_name_to_string +let option_to_string = Print.option_to_string +let type_var_to_string = Print.Types.type_var_to_string +let integer_type_to_string = Print.Types.integer_type_to_string +let scalar_value_to_string = Print.Values.scalar_value_to_string + +let mk_type_formatter (type_decls : T.type_decl TypeDeclId.Map.t) + (type_params : type_var list) : type_formatter = + let type_var_id_to_string vid = + let var = T.TypeVarId.nth type_params vid in + type_var_to_string var + in + let type_decl_id_to_string def_id = + let def = T.TypeDeclId.Map.find def_id type_decls in + name_to_string def.name + in + { type_var_id_to_string; type_decl_id_to_string } + +(* TODO: there is a bit of duplication with Print.fun_decl_to_ast_formatter. + + TODO: use the pure defs as inputs? Note that it is a bit annoying for the + functions (there is a difference between the forward/backward functions...) + while we only need those definitions to lookup proper names for the def ids. +*) +let mk_ast_formatter (type_decls : T.type_decl TypeDeclId.Map.t) + (fun_decls : A.fun_decl FunDeclId.Map.t) + (global_decls : A.global_decl GlobalDeclId.Map.t) + (type_params : type_var list) : ast_formatter = + let type_var_id_to_string vid = + let var = T.TypeVarId.nth type_params vid in + type_var_to_string var + in + let type_decl_id_to_string def_id = + let def = T.TypeDeclId.Map.find def_id type_decls in + name_to_string def.name + in + let adt_variant_to_string = + Print.Contexts.type_ctx_to_adt_variant_to_string_fun type_decls + in + let var_id_to_string vid = + (* TODO: somehow lookup in the context *) + "^" ^ VarId.to_string vid + in + let adt_field_names = + Print.Contexts.type_ctx_to_adt_field_names_fun type_decls + in + let adt_field_to_string = + Print.LlbcAst.type_ctx_to_adt_field_to_string_fun type_decls + in + let fun_decl_id_to_string def_id = + let def = FunDeclId.Map.find def_id fun_decls in + fun_name_to_string def.name + in + let global_decl_id_to_string def_id = + let def = GlobalDeclId.Map.find def_id global_decls in + global_name_to_string def.name + in + { + type_var_id_to_string; + type_decl_id_to_string; + adt_variant_to_string; + var_id_to_string; + adt_field_names; + adt_field_to_string; + fun_decl_id_to_string; + global_decl_id_to_string; + } + +let type_id_to_string (fmt : type_formatter) (id : type_id) : string = + match id with + | AdtId id -> fmt.type_decl_id_to_string id + | Tuple -> "" + | Assumed aty -> ( + match aty with + | State -> "State" + | Result -> "Result" + | Option -> "Option" + | Vec -> "Vec") + +let rec ty_to_string (fmt : type_formatter) (ty : ty) : string = + match ty with + | Adt (id, tys) -> ( + let tys = List.map (ty_to_string fmt) tys in + match id with + | Tuple -> "(" ^ String.concat " * " tys ^ ")" + | AdtId _ | Assumed _ -> + let tys = if tys = [] then "" else " " ^ String.concat " " tys in + type_id_to_string fmt id ^ tys) + | TypeVar tv -> fmt.type_var_id_to_string tv + | Bool -> "bool" + | Char -> "char" + | Integer int_ty -> integer_type_to_string int_ty + | Str -> "str" + | Array aty -> "[" ^ ty_to_string fmt aty ^ "; ?]" + | Slice sty -> "[" ^ ty_to_string fmt sty ^ "]" + | Arrow (arg_ty, ret_ty) -> + ty_to_string fmt arg_ty ^ " -> " ^ ty_to_string fmt ret_ty + +let field_to_string fmt (f : field) : string = + match f.field_name with + | None -> ty_to_string fmt f.field_ty + | Some field_name -> field_name ^ " : " ^ ty_to_string fmt f.field_ty + +let variant_to_string fmt (v : variant) : string = + v.variant_name ^ "(" + ^ String.concat ", " (List.map (field_to_string fmt) v.fields) + ^ ")" + +let type_decl_to_string (fmt : type_formatter) (def : type_decl) : string = + let types = def.type_params in + let name = name_to_string def.name in + let params = + if types = [] then "" + else " " ^ String.concat " " (List.map type_var_to_string types) + in + match def.kind with + | Struct fields -> + if List.length fields > 0 then + let fields = + String.concat "," + (List.map (fun f -> "\n " ^ field_to_string fmt f) fields) + in + "struct " ^ name ^ params ^ "{" ^ fields ^ "}" + else "struct " ^ name ^ params ^ "{}" + | Enum variants -> + let variants = + List.map (fun v -> "| " ^ variant_to_string fmt v) variants + in + let variants = String.concat "\n" variants in + "enum " ^ name ^ params ^ " =\n" ^ variants + | Opaque -> "opaque type " ^ name ^ params + +let var_to_varname (v : var) : string = + match v.basename with + | Some name -> name ^ "^" ^ VarId.to_string v.id + | None -> "^" ^ VarId.to_string v.id + +let var_to_string (fmt : type_formatter) (v : var) : string = + let varname = var_to_varname v in + "(" ^ varname ^ " : " ^ ty_to_string fmt v.ty ^ ")" + +let rec mprojection_to_string (fmt : ast_formatter) (inside : string) + (p : mprojection) : string = + match p with + | [] -> inside + | pe :: p' -> ( + let s = mprojection_to_string fmt inside p' in + match pe.pkind with + | E.ProjOption variant_id -> + assert (variant_id = T.option_some_id); + assert (pe.field_id = T.FieldId.zero); + "(" ^ s ^ "as Option::Some)." ^ T.FieldId.to_string pe.field_id + | E.ProjTuple _ -> "(" ^ s ^ ")." ^ T.FieldId.to_string pe.field_id + | E.ProjAdt (adt_id, opt_variant_id) -> ( + let field_name = + match fmt.adt_field_to_string adt_id opt_variant_id pe.field_id with + | Some field_name -> field_name + | None -> T.FieldId.to_string pe.field_id + in + match opt_variant_id with + | None -> "(" ^ s ^ ")." ^ field_name + | Some variant_id -> + let variant_name = fmt.adt_variant_to_string adt_id variant_id in + "(" ^ s ^ " as " ^ variant_name ^ ")." ^ field_name)) + +let mplace_to_string (fmt : ast_formatter) (p : mplace) : string = + let name = match p.name with None -> "" | Some name -> name in + (* We add the "llbc" suffix to the variable index, because meta-places + * use indices of the variables in the original LLBC program, while + * regular places use indices for the pure variables: we want to make + * this explicit, otherwise it is confusing. *) + let name = name ^ "^" ^ V.VarId.to_string p.var_id ^ "llbc" in + mprojection_to_string fmt name p.projection + +let adt_variant_to_string (fmt : value_formatter) (adt_id : type_id) + (variant_id : VariantId.id option) : string = + match adt_id with + | Tuple -> "Tuple" + | AdtId def_id -> ( + (* "Regular" ADT *) + match variant_id with + | Some vid -> fmt.adt_variant_to_string def_id vid + | None -> fmt.type_decl_id_to_string def_id) + | Assumed aty -> ( + (* Assumed type *) + match aty with + | State -> + (* The [State] type is opaque: we can't get there *) + raise (Failure "Unreachable") + | Result -> + let variant_id = Option.get variant_id in + if variant_id = result_return_id then "@Result::Return" + else if variant_id = result_fail_id then "@Result::Fail" + else + raise (Failure "Unreachable: improper variant id for result type") + | Option -> + let variant_id = Option.get variant_id in + if variant_id = option_some_id then "@Option::Some " + else if variant_id = option_none_id then "@Option::None" + else + raise (Failure "Unreachable: improper variant id for result type") + | Vec -> + assert (variant_id = None); + "Vec") + +let adt_field_to_string (fmt : value_formatter) (adt_id : type_id) + (field_id : FieldId.id) : string = + match adt_id with + | Tuple -> + raise (Failure "Unreachable") + (* Tuples don't use the opaque field id for the field indices, but [int] *) + | AdtId def_id -> ( + (* "Regular" ADT *) + let fields = fmt.adt_field_names def_id None in + match fields with + | None -> FieldId.to_string field_id + | Some fields -> FieldId.nth fields field_id) + | Assumed aty -> ( + (* Assumed type *) + match aty with + | State | Vec -> + (* Opaque types: we can't get there *) + raise (Failure "Unreachable") + | Result | Option -> + (* Enumerations: we can't get there *) + raise (Failure "Unreachable")) + +(** TODO: we don't need a general function anymore (it is now only used for + patterns (i.e., patterns) + *) +let adt_g_value_to_string (fmt : value_formatter) + (value_to_string : 'v -> string) (variant_id : VariantId.id option) + (field_values : 'v list) (ty : ty) : string = + let field_values = List.map value_to_string field_values in + match ty with + | Adt (Tuple, _) -> + (* Tuple *) + "(" ^ String.concat ", " field_values ^ ")" + | Adt (AdtId def_id, _) -> + (* "Regular" ADT *) + let adt_ident = + match variant_id with + | Some vid -> fmt.adt_variant_to_string def_id vid + | None -> fmt.type_decl_id_to_string def_id + in + if field_values <> [] then + match fmt.adt_field_names def_id variant_id with + | None -> + let field_values = String.concat ", " field_values in + adt_ident ^ " (" ^ field_values ^ ")" + | Some field_names -> + let field_values = List.combine field_names field_values in + let field_values = + List.map + (fun (field, value) -> field ^ " = " ^ value ^ ";") + field_values + in + let field_values = String.concat " " field_values in + adt_ident ^ " { " ^ field_values ^ " }" + else adt_ident + | Adt (Assumed aty, _) -> ( + (* Assumed type *) + match aty with + | State -> + (* The [State] type is opaque: we can't get there *) + raise (Failure "Unreachable") + | Result -> + let variant_id = Option.get variant_id in + if variant_id = result_return_id then + match field_values with + | [ v ] -> "@Result::Return " ^ v + | _ -> raise (Failure "Result::Return takes exactly one value") + else if variant_id = result_fail_id then ( + assert (field_values = []); + "@Result::Fail") + else + raise (Failure "Unreachable: improper variant id for result type") + | Option -> + let variant_id = Option.get variant_id in + if variant_id = option_some_id then + match field_values with + | [ v ] -> "@Option::Some " ^ v + | _ -> raise (Failure "Option::Some takes exactly one value") + else if variant_id = option_none_id then ( + assert (field_values = []); + "@Option::None") + else + raise (Failure "Unreachable: improper variant id for result type") + | Vec -> + assert (variant_id = None); + let field_values = + List.mapi (fun i v -> string_of_int i ^ " -> " ^ v) field_values + in + "Vec [" ^ String.concat "; " field_values ^ "]") + | _ -> + let fmt = value_to_type_formatter fmt in + raise + (Failure + ("Inconsistently typed value: expected ADT type but found:" + ^ "\n- ty: " ^ ty_to_string fmt ty ^ "\n- variant_id: " + ^ Print.option_to_string VariantId.to_string variant_id)) + +let rec typed_pattern_to_string (fmt : ast_formatter) (v : typed_pattern) : + string = + match v.value with + | PatConcrete cv -> Print.Values.constant_value_to_string cv + | PatVar (v, None) -> var_to_string (ast_to_type_formatter fmt) v + | PatVar (v, Some mp) -> + let mp = "[@mplace=" ^ mplace_to_string fmt mp ^ "]" in + "(" ^ var_to_varname v ^ " " ^ mp ^ " : " + ^ ty_to_string (ast_to_type_formatter fmt) v.ty + ^ ")" + | PatDummy -> "_" + | PatAdt av -> + adt_g_value_to_string + (ast_to_value_formatter fmt) + (typed_pattern_to_string fmt) + av.variant_id av.field_values v.ty + +let fun_sig_to_string (fmt : ast_formatter) (sg : fun_sig) : string = + let ty_fmt = ast_to_type_formatter fmt in + let type_params = List.map type_var_to_string sg.type_params in + let inputs = List.map (ty_to_string ty_fmt) sg.inputs in + let output = ty_to_string ty_fmt sg.output in + let all_types = List.concat [ type_params; inputs; [ output ] ] in + String.concat " -> " all_types + +let inst_fun_sig_to_string (fmt : ast_formatter) (sg : inst_fun_sig) : string = + let ty_fmt = ast_to_type_formatter fmt in + let inputs = List.map (ty_to_string ty_fmt) sg.inputs in + let output = ty_to_string ty_fmt sg.output in + let all_types = List.append inputs [ output ] in + String.concat " -> " all_types + +let regular_fun_id_to_string (fmt : ast_formatter) (fun_id : A.fun_id) : string + = + match fun_id with + | A.Regular fid -> fmt.fun_decl_id_to_string fid + | A.Assumed fid -> ( + match fid with + | A.Replace -> "core::mem::replace" + | A.BoxNew -> "alloc::boxed::Box::new" + | A.BoxDeref -> "core::ops::deref::Deref::deref" + | A.BoxDerefMut -> "core::ops::deref::DerefMut::deref_mut" + | A.BoxFree -> "alloc::alloc::box_free" + | A.VecNew -> "alloc::vec::Vec::new" + | A.VecPush -> "alloc::vec::Vec::push" + | A.VecInsert -> "alloc::vec::Vec::insert" + | A.VecLen -> "alloc::vec::Vec::len" + | A.VecIndex -> "core::ops::index::Index::index" + | A.VecIndexMut -> + "core::ops::index::IndexMut::index_mut") + +let fun_suffix (rg_id : T.RegionGroupId.id option) : string = + match rg_id with + | None -> "" + | Some rg_id -> "@" ^ T.RegionGroupId.to_string rg_id + +let unop_to_string (unop : unop) : string = + match unop with + | Not -> "¬" + | Neg _ -> "-" + | Cast (src, tgt) -> + "cast<" ^ integer_type_to_string src ^ "," ^ integer_type_to_string tgt + ^ ">" + +let binop_to_string = Print.LlbcAst.binop_to_string + +let fun_id_to_string (fmt : ast_formatter) (fun_id : fun_id) : string = + match fun_id with + | Regular (fun_id, rg_id) -> + let f = regular_fun_id_to_string fmt fun_id in + f ^ fun_suffix rg_id + | Unop unop -> unop_to_string unop + | Binop (binop, int_ty) -> + binop_to_string binop ^ "<" ^ integer_type_to_string int_ty ^ ">" + +(** [inside]: controls the introduction of parentheses *) +let rec texpression_to_string (fmt : ast_formatter) (inside : bool) + (indent : string) (indent_incr : string) (e : texpression) : string = + match e.e with + | Var var_id -> + let s = fmt.var_id_to_string var_id in + if inside then "(" ^ s ^ ")" else s + | Const cv -> Print.Values.constant_value_to_string cv + | App _ -> + (* Recursively destruct the app, to have a pair (app, arguments list) *) + let app, args = destruct_apps e in + (* Convert to string *) + app_to_string fmt inside indent indent_incr app args + | Abs _ -> + let xl, e = destruct_abs_list e in + let e = abs_to_string fmt indent indent_incr xl e in + if inside then "(" ^ e ^ ")" else e + | Qualif _ -> + (* Qualifier without arguments *) + app_to_string fmt inside indent indent_incr e [] + | Let (monadic, lv, re, e) -> + let e = let_to_string fmt indent indent_incr monadic lv re e in + if inside then "(" ^ e ^ ")" else e + | Switch (scrutinee, body) -> + let e = switch_to_string fmt indent indent_incr scrutinee body in + if inside then "(" ^ e ^ ")" else e + | Meta (meta, e) -> ( + let meta_s = meta_to_string fmt meta in + let e = texpression_to_string fmt inside indent indent_incr e in + match meta with + | Assignment _ -> + let e = meta_s ^ "\n" ^ indent ^ e in + if inside then "(" ^ e ^ ")" else e + | MPlace _ -> "(" ^ meta_s ^ " " ^ e ^ ")") + +and app_to_string (fmt : ast_formatter) (inside : bool) (indent : string) + (indent_incr : string) (app : texpression) (args : texpression list) : + string = + (* There are two possibilities: either the [app] is an instantiated, + * top-level qualifier (function, ADT constructore...), or it is a "regular" + * expression *) + let app, tys = + match app.e with + | Qualif qualif -> + (* Qualifier case *) + (* Convert the qualifier identifier *) + let qualif_s = + match qualif.id with + | Func fun_id -> fun_id_to_string fmt fun_id + | Global global_id -> fmt.global_decl_id_to_string global_id + | AdtCons adt_cons_id -> + let variant_s = + adt_variant_to_string + (ast_to_value_formatter fmt) + adt_cons_id.adt_id adt_cons_id.variant_id + in + ConstStrings.constructor_prefix ^ variant_s + | Proj { adt_id; field_id } -> + let value_fmt = ast_to_value_formatter fmt in + let adt_s = adt_variant_to_string value_fmt adt_id None in + let field_s = adt_field_to_string value_fmt adt_id field_id in + (* Adopting an F*-like syntax *) + ConstStrings.constructor_prefix ^ adt_s ^ "?." ^ field_s + in + (* Convert the type instantiation *) + let ty_fmt = ast_to_type_formatter fmt in + let tys = List.map (ty_to_string ty_fmt) qualif.type_args in + (* *) + (qualif_s, tys) + | _ -> + (* "Regular" expression case *) + let inside = args <> [] || (args = [] && inside) in + (texpression_to_string fmt inside indent indent_incr app, []) + in + (* Convert the arguments. + * The arguments are expressions, so indentation might get weird... (though + * those expressions will in most cases just be values) *) + let arg_to_string = + let inside = true in + let indent1 = indent ^ indent_incr in + texpression_to_string fmt inside indent1 indent_incr + in + let args = List.map arg_to_string args in + let all_args = List.append tys args in + (* Put together *) + let e = + if all_args = [] then app else app ^ " " ^ String.concat " " all_args + in + (* Add parentheses *) + if all_args <> [] && inside then "(" ^ e ^ ")" else e + +and abs_to_string (fmt : ast_formatter) (indent : string) (indent_incr : string) + (xl : typed_pattern list) (e : texpression) : string = + let xl = List.map (typed_pattern_to_string fmt) xl in + let e = texpression_to_string fmt false indent indent_incr e in + "λ " ^ String.concat " " xl ^ ". " ^ e + +and let_to_string (fmt : ast_formatter) (indent : string) (indent_incr : string) + (monadic : bool) (lv : typed_pattern) (re : texpression) (e : texpression) : + string = + let indent1 = indent ^ indent_incr in + let inside = false in + let re = texpression_to_string fmt inside indent1 indent_incr re in + let e = texpression_to_string fmt inside indent indent_incr e in + let lv = typed_pattern_to_string fmt lv in + if monadic then lv ^ " <-- " ^ re ^ ";\n" ^ indent ^ e + else "let " ^ lv ^ " = " ^ re ^ " in\n" ^ indent ^ e + +and switch_to_string (fmt : ast_formatter) (indent : string) + (indent_incr : string) (scrutinee : texpression) (body : switch_body) : + string = + let indent1 = indent ^ indent_incr in + (* Printing can mess up on the scrutinee, because it is an expression - but + * in most situations it will be a value or a function call, so it should be + * ok*) + let scrut = texpression_to_string fmt true indent1 indent_incr scrutinee in + let e_to_string = texpression_to_string fmt false indent1 indent_incr in + match body with + | If (e_true, e_false) -> + let e_true = e_to_string e_true in + let e_false = e_to_string e_false in + "if " ^ scrut ^ "\n" ^ indent ^ "then\n" ^ indent1 ^ e_true ^ "\n" + ^ indent ^ "else\n" ^ indent1 ^ e_false + | Match branches -> + let branch_to_string (b : match_branch) : string = + let pat = typed_pattern_to_string fmt b.pat in + indent ^ "| " ^ pat ^ " ->\n" ^ indent1 ^ e_to_string b.branch + in + let branches = List.map branch_to_string branches in + "match " ^ scrut ^ " with\n" ^ String.concat "\n" branches + +and meta_to_string (fmt : ast_formatter) (meta : meta) : string = + let meta = + match meta with + | Assignment (lp, rv, rp) -> + let rp = + match rp with + | None -> "" + | Some rp -> " [@src=" ^ mplace_to_string fmt rp ^ "]" + in + "@assign(" ^ mplace_to_string fmt lp ^ " := " + ^ texpression_to_string fmt false "" "" rv + ^ rp ^ ")" + | MPlace mp -> "@mplace=" ^ mplace_to_string fmt mp + in + "@meta[" ^ meta ^ "]" + +let fun_decl_to_string (fmt : ast_formatter) (def : fun_decl) : string = + let type_fmt = ast_to_type_formatter fmt in + let name = fun_name_to_string def.basename ^ fun_suffix def.back_id in + let signature = fun_sig_to_string fmt def.signature in + match def.body with + | None -> "val " ^ name ^ " :\n " ^ signature + | Some body -> + let inside = false in + let indent = " " in + let inputs = List.map (var_to_string type_fmt) body.inputs in + let inputs = + if inputs = [] then indent + else " fun " ^ String.concat " " inputs ^ " ->\n" ^ indent + in + let body = texpression_to_string fmt inside indent indent body.body in + "let " ^ name ^ " :\n " ^ signature ^ " =\n" ^ inputs ^ body diff --git a/compiler/Pure.ml b/compiler/Pure.ml new file mode 100644 index 00000000..77265f75 --- /dev/null +++ b/compiler/Pure.ml @@ -0,0 +1,581 @@ +open Identifiers +open Names +module T = Types +module V = Values +module E = Expressions +module A = LlbcAst +module TypeDeclId = T.TypeDeclId +module TypeVarId = T.TypeVarId +module RegionGroupId = T.RegionGroupId +module VariantId = T.VariantId +module FieldId = T.FieldId +module SymbolicValueId = V.SymbolicValueId +module FunDeclId = A.FunDeclId +module GlobalDeclId = A.GlobalDeclId + +(** We give an identifier to every phase of the synthesis (forward, backward + for group of regions 0, etc.) *) +module SynthPhaseId = IdGen () + +(** Pay attention to the fact that we also define a {!Values.VarId} module in Values *) +module VarId = IdGen () + +type integer_type = T.integer_type [@@deriving show, ord] + +(** The assumed types for the pure AST. + + In comparison with LLBC: + - we removed [Box] (because it is translated as the identity: [Box T == T]) + - we added: + - [Result]: the type used in the error monad. This allows us to have a + unified treatment of expressions (especially when we have to unfold the + monadic binds) + - [State]: the type of the state, when using state-error monads. Note that + this state is opaque to Aeneas (the user can define it, or leave it as + assumed) + *) +type assumed_ty = State | Result | Vec | Option [@@deriving show, ord] + +(* TODO: we should never directly manipulate [Return] and [Fail], but rather + * the monadic functions [return] and [fail] (makes treatment of error and + * state-error monads more uniform) *) +let result_return_id = VariantId.of_int 0 +let result_fail_id = VariantId.of_int 1 +let option_some_id = T.option_some_id +let option_none_id = T.option_none_id + +type type_id = AdtId of TypeDeclId.id | Tuple | Assumed of assumed_ty +[@@deriving show, ord] + +(** Ancestor for iter visitor for [ty] *) +class ['self] iter_ty_base = + object (_self : 'self) + inherit [_] VisitorsRuntime.iter + method visit_id : 'env -> TypeVarId.id -> unit = fun _ _ -> () + method visit_type_id : 'env -> type_id -> unit = fun _ _ -> () + method visit_integer_type : 'env -> integer_type -> unit = fun _ _ -> () + end + +(** Ancestor for map visitor for [ty] *) +class ['self] map_ty_base = + object (_self : 'self) + inherit [_] VisitorsRuntime.map + method visit_id : 'env -> TypeVarId.id -> TypeVarId.id = fun _ id -> id + method visit_type_id : 'env -> type_id -> type_id = fun _ id -> id + + method visit_integer_type : 'env -> integer_type -> integer_type = + fun _ ity -> ity + end + +type ty = + | Adt of type_id * ty list + (** {!Adt} encodes ADTs and tuples and assumed types. + + TODO: what about the ended regions? (ADTs may be parameterized + with several region variables. When giving back an ADT value, we may + be able to only give back part of the ADT. We need a way to encode + such "partial" ADTs. + *) + | TypeVar of TypeVarId.id + | Bool + | Char + | Integer of integer_type + | Str + | Array of ty (* TODO: this should be an assumed type?... *) + | Slice of ty (* TODO: this should be an assumed type?... *) + | Arrow of ty * ty +[@@deriving + show, + visitors + { + name = "iter_ty"; + variety = "iter"; + ancestors = [ "iter_ty_base" ]; + nude = true (* Don't inherit {!VisitorsRuntime.iter} *); + concrete = true; + polymorphic = false; + }, + visitors + { + name = "map_ty"; + variety = "map"; + ancestors = [ "map_ty_base" ]; + nude = true (* Don't inherit {!VisitorsRuntime.iter} *); + concrete = true; + polymorphic = false; + }] + +type field = { field_name : string option; field_ty : ty } [@@deriving show] +type variant = { variant_name : string; fields : field list } [@@deriving show] + +type type_decl_kind = Struct of field list | Enum of variant list | Opaque +[@@deriving show] + +type type_var = T.type_var [@@deriving show] + +type type_decl = { + def_id : TypeDeclId.id; + name : name; + type_params : type_var list; + kind : type_decl_kind; +} +[@@deriving show] + +type scalar_value = V.scalar_value [@@deriving show] +type constant_value = V.constant_value [@@deriving show] + +(** Because we introduce a lot of temporary variables, the list of variables + is not fixed: we thus must carry all its information with the variable + itself. + *) +type var = { + id : VarId.id; + basename : string option; + (** The "basename" is used to generate a meaningful name for the variable + (by potentially adding an index to uniquely identify it). + *) + ty : ty; +} +[@@deriving show] + +(* TODO: we might want to redefine field_proj_kind here, to prevent field accesses + * on enumerations. + * Also: tuples... + * Rmk: projections are actually only used as meta-data. + * *) +type mprojection_elem = { pkind : E.field_proj_kind; field_id : FieldId.id } +[@@deriving show] + +type mprojection = mprojection_elem list [@@deriving show] + +(** "Meta" place. + + Meta-data retrieved from the symbolic execution, which gives provenance + information about the values. We use this to generate names for the variables + we introduce. + *) +type mplace = { + var_id : V.VarId.id; + name : string option; + projection : mprojection; +} +[@@deriving show] + +type variant_id = VariantId.id [@@deriving show] + +(** Ancestor for [iter_pat_var_or_dummy] visitor *) +class ['self] iter_value_base = + object (_self : 'self) + inherit [_] VisitorsRuntime.iter + method visit_constant_value : 'env -> constant_value -> unit = fun _ _ -> () + method visit_var : 'env -> var -> unit = fun _ _ -> () + method visit_mplace : 'env -> mplace -> unit = fun _ _ -> () + method visit_ty : 'env -> ty -> unit = fun _ _ -> () + method visit_variant_id : 'env -> variant_id -> unit = fun _ _ -> () + end + +(** Ancestor for [map_typed_rvalue] visitor *) +class ['self] map_value_base = + object (_self : 'self) + inherit [_] VisitorsRuntime.map + + method visit_constant_value : 'env -> constant_value -> constant_value = + fun _ x -> x + + method visit_var : 'env -> var -> var = fun _ x -> x + method visit_mplace : 'env -> mplace -> mplace = fun _ x -> x + method visit_ty : 'env -> ty -> ty = fun _ x -> x + method visit_variant_id : 'env -> variant_id -> variant_id = fun _ x -> x + end + +(** Ancestor for [reduce_typed_rvalue] visitor *) +class virtual ['self] reduce_value_base = + object (self : 'self) + inherit [_] VisitorsRuntime.reduce + + method visit_constant_value : 'env -> constant_value -> 'a = + fun _ _ -> self#zero + + method visit_var : 'env -> var -> 'a = fun _ _ -> self#zero + method visit_mplace : 'env -> mplace -> 'a = fun _ _ -> self#zero + method visit_ty : 'env -> ty -> 'a = fun _ _ -> self#zero + method visit_variant_id : 'env -> variant_id -> 'a = fun _ _ -> self#zero + end + +(** Ancestor for [mapreduce_typed_rvalue] visitor *) +class virtual ['self] mapreduce_value_base = + object (self : 'self) + inherit [_] VisitorsRuntime.mapreduce + + method visit_constant_value : 'env -> constant_value -> constant_value * 'a + = + fun _ x -> (x, self#zero) + + method visit_var : 'env -> var -> var * 'a = fun _ x -> (x, self#zero) + + method visit_mplace : 'env -> mplace -> mplace * 'a = + fun _ x -> (x, self#zero) + + method visit_ty : 'env -> ty -> ty * 'a = fun _ x -> (x, self#zero) + + method visit_variant_id : 'env -> variant_id -> variant_id * 'a = + fun _ x -> (x, self#zero) + end + +(** A pattern (which appears on the left of assignments, in matches, etc.). *) +type pattern = + | PatConcrete of constant_value + (** {!PatConcrete} is necessary because we merge the switches over integer + values and the matches over enumerations *) + | PatVar of var * mplace option + | PatDummy (** Ignored value: [_]. *) + | PatAdt of adt_pattern + +and adt_pattern = { + variant_id : variant_id option; + field_values : typed_pattern list; +} + +and typed_pattern = { value : pattern; ty : ty } +[@@deriving + show, + visitors + { + name = "iter_typed_pattern"; + variety = "iter"; + ancestors = [ "iter_value_base" ]; + nude = true (* Don't inherit {!VisitorsRuntime.iter} *); + concrete = true; + polymorphic = false; + }, + visitors + { + name = "map_typed_pattern"; + variety = "map"; + ancestors = [ "map_value_base" ]; + nude = true (* Don't inherit {!VisitorsRuntime.iter} *); + concrete = true; + polymorphic = false; + }, + visitors + { + name = "reduce_typed_pattern"; + variety = "reduce"; + ancestors = [ "reduce_value_base" ]; + nude = true (* Don't inherit {!VisitorsRuntime.iter} *); + polymorphic = false; + }, + visitors + { + name = "mapreduce_typed_pattern"; + variety = "mapreduce"; + ancestors = [ "mapreduce_value_base" ]; + nude = true (* Don't inherit {!VisitorsRuntime.iter} *); + polymorphic = false; + }] + +type unop = Not | Neg of integer_type | Cast of integer_type * integer_type +[@@deriving show, ord] + +type fun_id = + | Regular of A.fun_id * T.RegionGroupId.id option + (** Backward id: [Some] if the function is a backward function, [None] + if it is a forward function. + + TODO: we need to redefine A.fun_id here, to add [fail] and + [return] (important to get a unified treatment of the state-error + monad). For now, when using the state-error monad: extraction + works only if we unfold all the monadic let-bindings, and we + then replace the content of the occurrences of [Return] to also + return the state (which is really super ugly). + *) + | Unop of unop + | Binop of E.binop * integer_type +[@@deriving show, ord] + +(** An identifier for an ADT constructor *) +type adt_cons_id = { adt_id : type_id; variant_id : variant_id option } +[@@deriving show] + +(** Projection - For now we don't support projection of tuple fields + (because not all the backends have syntax for this). + *) +type projection = { adt_id : type_id; field_id : FieldId.id } [@@deriving show] + +type qualif_id = + | Func of fun_id + | Global of GlobalDeclId.id + | AdtCons of adt_cons_id (** A function or ADT constructor identifier *) + | Proj of projection (** Field projector *) +[@@deriving show] + +(** An instantiated qualified. + + Note that for now we have a clear separation between types and expressions, + which explains why we have the [type_params] field: a function or ADT + constructor is always fully instantiated. + *) +type qualif = { id : qualif_id; type_args : ty list } [@@deriving show] + +type var_id = VarId.id [@@deriving show] + +(** Ancestor for [iter_expression] visitor *) +class ['self] iter_expression_base = + object (_self : 'self) + inherit [_] iter_typed_pattern + method visit_integer_type : 'env -> integer_type -> unit = fun _ _ -> () + method visit_var_id : 'env -> var_id -> unit = fun _ _ -> () + method visit_qualif : 'env -> qualif -> unit = fun _ _ -> () + end + +(** Ancestor for [map_expression] visitor *) +class ['self] map_expression_base = + object (_self : 'self) + inherit [_] map_typed_pattern + + method visit_integer_type : 'env -> integer_type -> integer_type = + fun _ x -> x + + method visit_var_id : 'env -> var_id -> var_id = fun _ x -> x + method visit_qualif : 'env -> qualif -> qualif = fun _ x -> x + end + +(** Ancestor for [reduce_expression] visitor *) +class virtual ['self] reduce_expression_base = + object (self : 'self) + inherit [_] reduce_typed_pattern + + method visit_integer_type : 'env -> integer_type -> 'a = + fun _ _ -> self#zero + + method visit_var_id : 'env -> var_id -> 'a = fun _ _ -> self#zero + method visit_qualif : 'env -> qualif -> 'a = fun _ _ -> self#zero + end + +(** Ancestor for [mapreduce_expression] visitor *) +class virtual ['self] mapreduce_expression_base = + object (self : 'self) + inherit [_] mapreduce_typed_pattern + + method visit_integer_type : 'env -> integer_type -> integer_type * 'a = + fun _ x -> (x, self#zero) + + method visit_var_id : 'env -> var_id -> var_id * 'a = + fun _ x -> (x, self#zero) + + method visit_qualif : 'env -> qualif -> qualif * 'a = + fun _ x -> (x, self#zero) + end + +(** **Rk.:** here, {!expression} is not at all equivalent to the expressions + used in LLBC. They are lambda-calculus expressions, and are thus actually + more general than the LLBC statements, in a sense. + *) +type expression = + | Var of var_id (** a variable *) + | Const of constant_value + | App of texpression * texpression + (** Application of a function to an argument. + + The function calls are still quite structured. + Change that?... We might want to have a "normal" lambda calculus + app (with head and argument): this would allow us to replace some + field accesses with calls to projectors over fields (when there + are clashes of field names, some provers like F* get pretty bad...) + *) + | Abs of typed_pattern * texpression (** Lambda abstraction: [fun x -> e] *) + | Qualif of qualif (** A top-level qualifier *) + | Let of bool * typed_pattern * texpression * texpression + (** Let binding. + + TODO: the boolean should be replaced by an enum: sometimes we use + the error-monad, sometimes we use the state-error monad (and we + do this an a per-function basis! For instance, arithmetic functions + are always in the error monad). + + The boolean controls whether the let is monadic or not. + For instance, in F*: + - non-monadic: [let x = ... in ...] + - monadic: [x <-- ...; ...] + + Note that we are quite general for the left-value on purpose; this + is used in several situations: + + 1. When deconstructing a tuple: + {[ + let (x, y) = p in ... + ]} + (not all languages have syntax like [p.0], [p.1]... and it is more + readable anyway). + + 2. When expanding an enumeration with one variant. + In this case, {!Let} has to be understood as: + {[ + let Cons x tl = ls in + ... + ]} + + Note that later, depending on the language we extract to, we can + eventually update it to something like this (for F*, for instance): + {[ + let x = Cons?.v ls in + let tl = Cons?.tl ls in + ... + ]} + *) + | Switch of texpression * switch_body + | Meta of (meta[@opaque]) * texpression (** Meta-information *) + +and switch_body = If of texpression * texpression | Match of match_branch list +and match_branch = { pat : typed_pattern; branch : texpression } +and texpression = { e : expression; ty : ty } + +(** Meta-value (converted to an expression). It is important that the content + is opaque. + + TODO: is it possible to mark the whole mvalue type as opaque? + *) +and mvalue = (texpression[@opaque]) + +and meta = + | Assignment of mplace * mvalue * mplace option + (** Meta-information stored in the AST. + + The first mplace stores the destination. + The mvalue stores the value which is put in the destination + The second (optional) mplace stores the origin. + *) + | MPlace of mplace (** Meta-information about the origin of a value *) +[@@deriving + show, + visitors + { + name = "iter_expression"; + variety = "iter"; + ancestors = [ "iter_expression_base" ]; + nude = true (* Don't inherit {!VisitorsRuntime.iter} *); + concrete = true; + }, + visitors + { + name = "map_expression"; + variety = "map"; + ancestors = [ "map_expression_base" ]; + nude = true (* Don't inherit {!VisitorsRuntime.iter} *); + concrete = true; + }, + visitors + { + name = "reduce_expression"; + variety = "reduce"; + ancestors = [ "reduce_expression_base" ]; + nude = true (* Don't inherit {!VisitorsRuntime.iter} *); + }, + visitors + { + name = "mapreduce_expression"; + variety = "mapreduce"; + ancestors = [ "mapreduce_expression_base" ]; + nude = true (* Don't inherit {!VisitorsRuntime.iter} *); + }] + +(** Information about the "effect" of a function *) +type fun_effect_info = { + input_state : bool; (** [true] if the function takes a state as input *) + output_state : bool; + (** [true] if the function outputs a state (it then lives + in a state monad) *) + can_fail : bool; (** [true] if the return type is a [result] *) +} + +(** Meta information about a function signature *) +type fun_sig_info = { + num_fwd_inputs : int; + (** The number of input types for forward computation *) + num_back_inputs : int option; + (** The number of additional inputs for the backward computation (if pertinent) *) + effect_info : fun_effect_info; +} + +(** A function signature. + + We have the following cases: + - forward function: + [in_ty0 -> ... -> in_tyn -> out_ty] (* pure function *) + `in_ty0 -> ... -> in_tyn -> result out_ty` (* error-monad *) + `in_ty0 -> ... -> in_tyn -> state -> result (state & out_ty)` (* state-error *) + - backward function: + `in_ty0 -> ... -> in_tyn -> back_in0 -> ... back_inm -> (back_out0 & ... & back_outp)` (* pure function *) + `in_ty0 -> ... -> in_tyn -> back_in0 -> ... back_inm -> + result (back_out0 & ... & back_outp)` (* error-monad *) + `in_ty0 -> ... -> in_tyn -> state -> back_in0 -> ... back_inm -> + result (back_out0 & ... & back_outp)` (* state-error *) + + Note that a backward function never returns (i.e., updates) a state: only + forward functions do so. Also, the state input parameter is *betwee* + the forward inputs and the backward inputs. + + The function's type should be given by `mk_arrows sig.inputs sig.output`. + We provide additional meta-information: + - we divide between forward inputs and backward inputs (i.e., inputs specific + to the forward functions, and additional inputs necessary if the signature is + for a backward function) + - we have booleans to give us the fact that the function takes a state as + input, or can fail, etc. without having to inspect the signature + - etc. + *) +type fun_sig = { + type_params : type_var list; + inputs : ty list; + output : ty; + doutputs : ty list; + (** The "decomposed" list of outputs. + + In case of a forward function, the list has length = 1, for the + type of the returned value. + + In case of backward function, the list contains all the types of + all the given back values (there is at most one type per forward + input argument). + + Ex.: + {[ + fn choose<'a, T>(b : bool, x : &'a mut T, y : &'a mut T) -> &'a mut T; + ]} + Decomposed outputs: + - forward function: [T] + - backward function: [T; T] (for "x" and "y") + + *) + info : fun_sig_info; (** Additional information *) +} + +(** An instantiated function signature. See {!fun_sig} *) +type inst_fun_sig = { + inputs : ty list; + output : ty; + doutputs : ty list; + info : fun_sig_info; +} + +type fun_body = { + inputs : var list; + inputs_lvs : typed_pattern list; + (** The inputs seen as patterns. Allows to make transformations, for example + to replace unused variables by [_] *) + body : texpression; +} + +type fun_decl = { + def_id : FunDeclId.id; + back_id : T.RegionGroupId.id option; + basename : fun_name; + (** The "base" name of the function. + + The base name is the original name of the Rust function. We add suffixes + (to identify the forward/backward functions) later. + *) + signature : fun_sig; + is_global_decl_body : bool; + body : fun_body option; +} diff --git a/compiler/PureMicroPasses.ml b/compiler/PureMicroPasses.ml new file mode 100644 index 00000000..3edae38a --- /dev/null +++ b/compiler/PureMicroPasses.ml @@ -0,0 +1,1375 @@ +(** The following module defines micro-passes which operate on the pure AST *) + +open Pure +open PureUtils +open TranslateCore +module V = Values + +(** The local logger *) +let log = L.pure_micro_passes_log + +(** A configuration to control the application of the passes *) +type config = { + decompose_monadic_let_bindings : bool; + (** Some provers like F* don't support the decomposition of return values + in monadic let-bindings: + {[ + // NOT supported in F* + let (x, y) <-- f (); + ... + ]} + + In such situations, we might want to introduce an intermediate + assignment: + {[ + let tmp <-- f (); + let (x, y) = tmp in + ... + ]} + *) + unfold_monadic_let_bindings : bool; + (** Controls the unfolding of monadic let-bindings to explicit matches: + + [y <-- f x; ...] + + becomes: + + [match f x with | Failure -> Failure | Return y -> ...] + + + This is useful when extracting to F*: the support for monadic + definitions is not super powerful. + Note that when {!field:unfold_monadic_let_bindings} is true, setting + {!field:decompose_monadic_let_bindings} to true and only makes the code + more verbose. + *) + filter_useless_monadic_calls : bool; + (** Controls whether we try to filter the calls to monadic functions + (which can fail) when their outputs are not used. + + See the comments for {!expression_contains_child_call_in_all_paths} + for additional explanations. + + TODO: rename to {!filter_useless_monadic_calls} + *) + filter_useless_functions : bool; + (** If {!filter_useless_monadic_calls} is activated, some functions + become useless: if this option is true, we don't extract them. + + The calls to functions which always get filtered are: + - the forward functions with unit return value + - the backward functions which don't output anything (backward + functions coming from rust functions with no mutable borrows + as input values - note that if a function doesn't take mutable + borrows as inputs, it can't return mutable borrows; we actually + dynamically check for that). + *) +} + +(** Small utility. + + We sometimes have to insert new fresh variables in a function body, in which + case we need to make their indices greater than the indices of all the variables + in the body. + TODO: things would be simpler if we used a better representation of the + variables indices... + *) +let get_body_min_var_counter (body : fun_body) : VarId.generator = + (* Find the max id in the input variables - some of them may have been + * filtered from the body *) + let min_input_id = + List.fold_left + (fun id (var : var) -> VarId.max id var.id) + VarId.zero body.inputs + in + let obj = + object + inherit [_] reduce_expression + method zero _ = min_input_id + method plus id0 id1 _ = VarId.max (id0 ()) (id1 ()) + (* Get the maximum *) + + (** For the patterns *) + method! visit_var _ v _ = v.id + + (** For the rvalues *) + method! visit_Var _ vid _ = vid + end + in + (* Find the max counter in the body *) + let id = obj#visit_expression () body.body.e () in + VarId.generator_from_incr_id id + +(** "pretty-name context": see [compute_pretty_names] *) +type pn_ctx = { + pure_vars : string VarId.Map.t; + (** Information about the pure variables used in the synthesized program *) + llbc_vars : string V.VarId.Map.t; + (** Information about the LLBC variables used in the original program *) +} + +(** This function computes pretty names for the variables in the pure AST. It + relies on the "meta"-place information in the AST to generate naming + constraints, and then uses those to compute the names. + + The way it works is as follows: + - we only modify the names of the unnamed variables + - whenever we see an rvalue/pattern which is exactly an unnamed variable, + and this value is linked to some meta-place information which contains + a name and an empty path, we consider we should use this name + - we try to propagate naming constraints on the pure variables use in the + synthesized programs, and also on the LLBC variables from the original + program (information about the LLBC variables is stored in the meta-places) + + + Something important is that, for every variable we find, the name of this + variable can be influenced by the information we find *below* in the AST. + + For instance, the following situations happen: + + - let's say we evaluate: + {[ + match (ls : List) { + List::Cons(x, hd) => { + ... + } + } + ]} + + Actually, in MIR, we get: + {[ + tmp := discriminant(ls); + switch tmp { + 0 => { + x := (ls as Cons).0; // (i) + hd := (ls as Cons).1; // (ii) + ... + } + } + ]} + If [ls] maps to a symbolic value [s0] upon evaluating the match in symbolic + mode, we expand this value upon evaluating [tmp = discriminant(ls)]. + However, at this point, we don't know which should be the names of + the symbolic values we introduce for the fields of [Cons]! + + Let's imagine we have (for the [Cons] branch): [s0 ~~> Cons s1 s2]. + The assigments at (i) and (ii) lead to the following binding in the + evaluation context: + {[ + x -> s1 + hd -> s2 + ]} + + When generating the symbolic AST, we save as meta-information that we + assign [s1] to the place [x] and [s2] to the place [hd]. This way, + we learn we can use the names [x] and [hd] for the variables which are + introduced by the match: + {[ + match ls with + | Cons x hd -> ... + | ... + ]} + - Assignments: + [let x [@mplace=lp] = v [@mplace = rp] in ...] + + We propagate naming information across the assignments. This is important + because many reassignments using temporary, anonymous variables are + introduced during desugaring. + + - Given back values (introduced by backward functions): + Let's say we have the following Rust code: + {[ + let py = id(&mut x); + *py = 2; + assert!(x == 2); + ]} + + After desugaring, we get the following MIR: + {[ + ^0 = &mut x; // anonymous variable + py = id(move ^0); + *py += 2; + assert!(x == 2); + ]} + + We want this to be translated as: + {[ + let py = id_fwd x in + let py1 = py + 2 in + let x1 = id_back x py1 in // <-- x1 is "given back": doesn't appear in the original MIR + assert(x1 = 2); + ]} + + We want to notice that the value given back by [id_back] is given back for "x", + so we should use "x" as the basename (hence the resulting name "x1"). However, + this is non-trivial, because after desugaring the input argument given to [id] + is not [&mut x] but [move ^0] (i.e., it comes from a temporary, anonymous + variable). For this reason, we use the meta-place [&mut x] as the meta-place + for the given back value (this is done during the synthesis), and propagate + naming information *also* on the LLBC variables (which are referenced by the + meta-places). + + This way, because of [^0 = &mut x], we can propagate the name "x" to the place + [^0], then to the given back variable across the function call. + + *) +let compute_pretty_names (def : fun_decl) : fun_decl = + (* Small helpers *) + (* + * When we do branchings, we need to merge (the constraints saved in) the + * contexts returned by the different branches. + * + * Note that by doing so, some mappings from var id to name + * in one context may be overriden by the ones in the other context. + * + * This should be ok because: + * - generally, the overriden variables should have been introduced *inside* + * the branches, in which case we don't care + * - or they were introduced before, in which case the naming should generally + * be consistent? In the worse case, it isn't, but it leads only to less + * readable code, not to unsoundness. This case should be pretty rare, + * also. + *) + let merge_ctxs (ctx0 : pn_ctx) (ctx1 : pn_ctx) : pn_ctx = + let pure_vars = + VarId.Map.fold + (fun id name ctx -> VarId.Map.add id name ctx) + ctx0.pure_vars ctx1.pure_vars + in + let llbc_vars = + V.VarId.Map.fold + (fun id name ctx -> V.VarId.Map.add id name ctx) + ctx0.llbc_vars ctx1.llbc_vars + in + { pure_vars; llbc_vars } + in + let empty_ctx = + { pure_vars = VarId.Map.empty; llbc_vars = V.VarId.Map.empty } + in + let merge_ctxs_ls (ctxs : pn_ctx list) : pn_ctx = + List.fold_left (fun ctx0 ctx1 -> merge_ctxs ctx0 ctx1) empty_ctx ctxs + in + + (* + * The way we do is as follows: + * - we explore the expressions + * - we register the variables introduced by the let-bindings + * - we use the naming information we find (through the variables and the + * meta-places) to update our context (i.e., maps from variable ids to + * names) + * - we use this information to update the names of the variables used in the + * expressions + *) + + (* Register a variable for constraints propagation - used when an variable is + * introduced (left-hand side of a left binding) *) + let register_var (ctx : pn_ctx) (v : var) : pn_ctx = + assert (not (VarId.Map.mem v.id ctx.pure_vars)); + match v.basename with + | None -> ctx + | Some name -> + let pure_vars = VarId.Map.add v.id name ctx.pure_vars in + { ctx with pure_vars } + in + (* Update a variable - used to update an expression after we computed constraints *) + let update_var (ctx : pn_ctx) (v : var) (mp : mplace option) : var = + match v.basename with + | Some _ -> v + | None -> ( + match VarId.Map.find_opt v.id ctx.pure_vars with + | Some basename -> { v with basename = Some basename } + | None -> + if Option.is_some mp then + match + V.VarId.Map.find_opt (Option.get mp).var_id ctx.llbc_vars + with + | None -> v + | Some basename -> { v with basename = Some basename } + else v) + in + (* Update an pattern - used to update an expression after we computed constraints *) + let update_typed_pattern ctx (lv : typed_pattern) : typed_pattern = + let obj = + object + inherit [_] map_typed_pattern + method! visit_PatVar _ v mp = PatVar (update_var ctx v mp, mp) + end + in + obj#visit_typed_pattern () lv + in + + (* Register an mplace the first time we find one *) + let register_mplace (mp : mplace) (ctx : pn_ctx) : pn_ctx = + match (V.VarId.Map.find_opt mp.var_id ctx.llbc_vars, mp.name) with + | None, Some name -> + let llbc_vars = V.VarId.Map.add mp.var_id name ctx.llbc_vars in + { ctx with llbc_vars } + | _ -> ctx + in + + (* Register the fact that [name] can be used for the pure variable identified + * by [var_id] (will add this name in the map if the variable is anonymous) *) + let add_pure_var_constraint (var_id : VarId.id) (name : string) (ctx : pn_ctx) + : pn_ctx = + let pure_vars = + if VarId.Map.mem var_id ctx.pure_vars then ctx.pure_vars + else VarId.Map.add var_id name ctx.pure_vars + in + { ctx with pure_vars } + in + (* Similar to [add_pure_var_constraint], but for LLBC variables *) + let add_llbc_var_constraint (var_id : V.VarId.id) (name : string) + (ctx : pn_ctx) : pn_ctx = + let llbc_vars = + if V.VarId.Map.mem var_id ctx.llbc_vars then ctx.llbc_vars + else V.VarId.Map.add var_id name ctx.llbc_vars + in + { ctx with llbc_vars } + in + (* Add a constraint: given a variable id and an associated meta-place, try to + * extract naming information from the meta-place and save it *) + let add_constraint (mp : mplace) (var_id : VarId.id) (ctx : pn_ctx) : pn_ctx = + (* Register the place *) + let ctx = register_mplace mp ctx in + (* Update the variable name *) + match (mp.name, mp.projection) with + | Some name, [] -> + (* Check if the variable already has a name - if not: insert the new name *) + let ctx = add_pure_var_constraint var_id name ctx in + let ctx = add_llbc_var_constraint mp.var_id name ctx in + ctx + | _ -> ctx + in + (* Specific case of constraint on rvalues *) + let add_right_constraint (mp : mplace) (rv : texpression) (ctx : pn_ctx) : + pn_ctx = + (* Register the place *) + let ctx = register_mplace mp ctx in + (* Add the constraint *) + match (unmeta rv).e with Var vid -> add_constraint mp vid ctx | _ -> ctx + in + (* Specific case of constraint on left values *) + let add_left_constraint (lv : typed_pattern) (ctx : pn_ctx) : pn_ctx = + let obj = + object (self) + inherit [_] reduce_typed_pattern + method zero _ = empty_ctx + method plus ctx0 ctx1 _ = merge_ctxs (ctx0 ()) (ctx1 ()) + + method! visit_PatVar _ v mp () = + (* Register the variable *) + let ctx = register_var (self#zero ()) v in + (* Register the mplace information if there is such information *) + match mp with Some mp -> add_constraint mp v.id ctx | None -> ctx + end + in + let ctx1 = obj#visit_typed_pattern () lv () in + merge_ctxs ctx ctx1 + in + + (* This is used to propagate constraint information about places in case of + * variable reassignments: we try to propagate the information from the + * rvalue to the left *) + let add_left_right_constraint (lv : typed_pattern) (re : texpression) + (ctx : pn_ctx) : pn_ctx = + (* We propagate constraints across variable reassignments: [^0 = x], + * if the destination doesn't have naming information *) + match lv.value with + | PatVar (({ id = _; basename = None; ty = _ } as lvar), lmp) -> + if + (* Check that there is not already a name for the variable *) + VarId.Map.mem lvar.id ctx.pure_vars + then ctx + else + (* We ignore the left meta-place information: it should have been taken + * care of by [add_left_constraint]. We try to use the right meta-place + * information *) + let add (name : string) (ctx : pn_ctx) : pn_ctx = + (* Add the constraint for the pure variable *) + let ctx = add_pure_var_constraint lvar.id name ctx in + (* Add the constraint for the LLBC variable *) + match lmp with + | None -> ctx + | Some lmp -> add_llbc_var_constraint lmp.var_id name ctx + in + (* We try to use the right-place information *) + let rmp, re = opt_unmeta_mplace re in + let ctx = + match rmp with + | Some { var_id; name; projection = [] } -> ( + if Option.is_some name then add (Option.get name) ctx + else + match V.VarId.Map.find_opt var_id ctx.llbc_vars with + | None -> ctx + | Some name -> add name ctx) + | _ -> ctx + in + (* We try to use the rvalue information, if it is a variable *) + let ctx = + match (unmeta re).e with + | Var rvar_id -> ( + match VarId.Map.find_opt rvar_id ctx.pure_vars with + | None -> ctx + | Some name -> add name ctx) + | _ -> ctx + in + ctx + | _ -> ctx + in + + (* *) + let rec update_texpression (e : texpression) (ctx : pn_ctx) : + pn_ctx * texpression = + let ty = e.ty in + let ctx, e = + match e.e with + | Var _ -> (* Nothing to do *) (ctx, e.e) + | Const _ -> (* Nothing to do *) (ctx, e.e) + | App (app, arg) -> + let ctx, app = update_texpression app ctx in + let ctx, arg = update_texpression arg ctx in + let e = App (app, arg) in + (ctx, e) + | Abs (x, e) -> update_abs x e ctx + | Qualif _ -> (* nothing to do *) (ctx, e.e) + | Let (monadic, lb, re, e) -> update_let monadic lb re e ctx + | Switch (scrut, body) -> update_switch_body scrut body ctx + | Meta (meta, e) -> update_meta meta e ctx + in + (ctx, { e; ty }) + (* *) + and update_abs (x : typed_pattern) (e : texpression) (ctx : pn_ctx) : + pn_ctx * expression = + (* We first add the left-constraint *) + let ctx = add_left_constraint x ctx in + (* Update the expression, and add additional constraints *) + let ctx, e = update_texpression e ctx in + (* Update the abstracted value *) + let x = update_typed_pattern ctx x in + (* Put together *) + (ctx, Abs (x, e)) + (* *) + and update_let (monadic : bool) (lv : typed_pattern) (re : texpression) + (e : texpression) (ctx : pn_ctx) : pn_ctx * expression = + (* We first add the left-constraint *) + let ctx = add_left_constraint lv ctx in + (* Then we try to propagate the right-constraints to the left, in case + * the left constraints didn't give naming information *) + let ctx = add_left_right_constraint lv re ctx in + let ctx, re = update_texpression re ctx in + let ctx, e = update_texpression e ctx in + let lv = update_typed_pattern ctx lv in + (ctx, Let (monadic, lv, re, e)) + (* *) + and update_switch_body (scrut : texpression) (body : switch_body) + (ctx : pn_ctx) : pn_ctx * expression = + let ctx, scrut = update_texpression scrut ctx in + + let ctx, body = + match body with + | If (e_true, e_false) -> + let ctx1, e_true = update_texpression e_true ctx in + let ctx2, e_false = update_texpression e_false ctx in + let ctx = merge_ctxs ctx1 ctx2 in + (ctx, If (e_true, e_false)) + | Match branches -> + let ctx_branches_ls = + List.map + (fun br -> + let ctx = add_left_constraint br.pat ctx in + let ctx, branch = update_texpression br.branch ctx in + let pat = update_typed_pattern ctx br.pat in + (ctx, { pat; branch })) + branches + in + let ctxs, branches = List.split ctx_branches_ls in + let ctx = merge_ctxs_ls ctxs in + (ctx, Match branches) + in + (ctx, Switch (scrut, body)) + (* *) + and update_meta (meta : meta) (e : texpression) (ctx : pn_ctx) : + pn_ctx * expression = + let ctx = + match meta with + | Assignment (mp, rvalue, rmp) -> + let ctx = add_right_constraint mp rvalue ctx in + let ctx = + match (mp.projection, rmp) with + | [], Some { var_id; name; projection = [] } -> ( + let name = + match name with + | Some name -> Some name + | None -> V.VarId.Map.find_opt var_id ctx.llbc_vars + in + match name with + | None -> ctx + | Some name -> add_llbc_var_constraint mp.var_id name ctx) + | _ -> ctx + in + ctx + | MPlace mp -> add_right_constraint mp e ctx + in + let ctx, e = update_texpression e ctx in + let e = mk_meta meta e in + (ctx, e.e) + in + + let body = + match def.body with + | None -> None + | Some body -> + let input_names = + List.filter_map + (fun (v : var) -> + match v.basename with + | None -> None + | Some name -> Some (v.id, name)) + body.inputs + in + let ctx = + { + pure_vars = VarId.Map.of_list input_names; + llbc_vars = V.VarId.Map.empty; + } + in + let _, body_exp = update_texpression body.body ctx in + Some { body with body = body_exp } + in + { def with body } + +(** Remove the meta-information *) +let remove_meta (def : fun_decl) : fun_decl = + match def.body with + | None -> def + | Some body -> + let body = { body with body = PureUtils.remove_meta body.body } in + { def with body = Some body } + +(** Inline the useless variable (re-)assignments: + + A lot of intermediate variable assignments are introduced through the + compilation to MIR and by the translation itself (and the variable used + on the left is often unnamed). + + Note that many of them are just variable "reassignments": [let x = y in ...]. + Some others come from ?? + + TODO: how do we call that when we introduce intermediate variable assignments + for the arguments of a function call? + + [inline_named]: if [true], inline all the assignments of the form + [let VAR = VAR in ...], otherwise inline only the ones where the variable + on the left is anonymous. + + [inline_pure]: if [true], inline all the pure assignments where the variable + on the left is anonymous, but the assignments where the r-expression is + a non-primitive function call (i.e.: inline the binops, ADT constructions, + etc.). + + TODO: we have a smallish issue which is that rvalues should be merged with + expressions... For now, this forces us to substitute whenever we can, but + leave the let-bindings where they are, and eliminated them in a subsequent + pass (if they are useless). + *) +let inline_useless_var_reassignments (inline_named : bool) (inline_pure : bool) + (def : fun_decl) : fun_decl = + let obj = + object (self) + inherit [_] map_expression as super + + (** Visit the let-bindings to filter the useless ones (and update + the substitution map while doing so *) + method! visit_Let (env : texpression VarId.Map.t) monadic lv re e = + (* In order to filter, we need to check first that: + * - the let-binding is not monadic + * - the left-value is a variable + *) + match (monadic, lv.value) with + | false, PatVar (lv_var, _) -> + (* We can filter if: *) + (* 1. the left variable is unnamed or [inline_named] is true *) + let filter_left = + match (inline_named, lv_var.basename) with + | true, _ | _, None -> true + | _ -> false + in + (* And either: + * 2.1 the right-expression is a variable or a global *) + let var_or_global = is_var re || is_global re in + (* Or: + * 2.2 the right-expression is a constant value, an ADT value, + * a projection or a primitive function call *and* the flag + * [inline_pure] is set *) + let pure_re = + is_const re + || + let app, _ = destruct_apps re in + match app.e with + | Qualif qualif -> ( + match qualif.id with + | AdtCons _ -> true (* ADT constructor *) + | Proj _ -> true (* Projector *) + | Func (Unop _ | Binop _) -> + true (* primitive function call *) + | Func (Regular _) -> false (* non-primitive function call *) + | _ -> false) + | _ -> false + in + let filter = + filter_left && (var_or_global || (inline_pure && pure_re)) + in + + (* Update the rhs (we may perform substitutions inside, and it is + * better to do them *before* we inline it *) + let re = self#visit_texpression env re in + (* Update the substitution environment *) + let env = if filter then VarId.Map.add lv_var.id re env else env in + (* Update the next expression *) + let e = self#visit_texpression env e in + (* Reconstruct the [let], only if the binding is not filtered *) + if filter then e.e else Let (monadic, lv, re, e) + | _ -> super#visit_Let env monadic lv re e + + (** Substitute the variables *) + method! visit_Var (env : texpression VarId.Map.t) (vid : VarId.id) = + match VarId.Map.find_opt vid env with + | None -> (* No substitution *) super#visit_Var env vid + | Some ne -> + (* Substitute - note that we need to reexplore, because + * there may be stacked substitutions, if we have: + * var0 --> var1 + * var1 --> var2. + *) + self#visit_expression env ne.e + end + in + match def.body with + | None -> def + | Some body -> + let body = + { body with body = obj#visit_texpression VarId.Map.empty body.body } + in + { def with body = Some body } + +(** Given a forward or backward function call, is there, for every execution + path, a child backward function called later with exactly the same input + list prefix? We use this to filter useless function calls: if there are + such child calls, we can remove this one (in case its outputs are not + used). + We do this check because we can't simply remove function calls whose + outputs are not used, as they might fail. However, if a function fails, + its children backward functions then fail on the same inputs (ignoring + the additional inputs those receive). + + For instance, if we have: + {[ + fn f<'a>(x : &'a mut T); + ]} + + We often have things like this in the synthesized code: + {[ + _ <-- f x; + ... + nx <-- f@back'a x y; + ... + ]} + + In this situation, we can remove the call [f x]. + *) +let expression_contains_child_call_in_all_paths (ctx : trans_ctx) + (fun_id0 : fun_id) (tys0 : ty list) (args0 : texpression list) + (e : texpression) : bool = + let check_call (fun_id1 : fun_id) (tys1 : ty list) (args1 : texpression list) + : bool = + (* Check the fun_ids, to see if call1's function is a child of call0's function *) + match (fun_id0, fun_id1) with + | Regular (id0, rg_id0), Regular (id1, rg_id1) -> + (* Both are "regular" calls: check if they come from the same rust function *) + if id0 = id1 then + (* Same rust functions: check the regions hierarchy *) + let call1_is_child = + match (rg_id0, rg_id1) with + | None, _ -> + (* The function used in call0 is the forward function: the one + * used in call1 is necessarily a child *) + true + | Some _, None -> + (* Opposite of previous case *) + false + | Some rg_id0, Some rg_id1 -> + if rg_id0 = rg_id1 then true + else + (* We need to use the regions hierarchy *) + (* First, lookup the signature of the LLBC function *) + let sg = + LlbcAstUtils.lookup_fun_sig id0 ctx.fun_context.fun_decls + in + (* Compute the set of ancestors of the function in call1 *) + let call1_ancestors = + LlbcAstUtils.list_parent_region_groups sg rg_id1 + in + (* Check if the function used in call0 is inside *) + T.RegionGroupId.Set.mem rg_id0 call1_ancestors + in + (* If call1 is a child, then we need to check if the input arguments + * used in call0 are a prefix of the input arguments used in call1 + * (note call1 being a child, it will likely consume strictly more + * given back values). + * *) + if call1_is_child then + let call1_args = + Collections.List.prefix (List.length args0) args1 + in + let args = List.combine args0 call1_args in + (* Note that the input values are expressions, *which may contain + * meta-values* (which we need to ignore). *) + let input_eq (v0, v1) = + PureUtils.remove_meta v0 = PureUtils.remove_meta v1 + in + (* Compare the input types and the prefix of the input arguments *) + tys0 = tys1 && List.for_all input_eq args + else (* Not a child *) + false + else (* Not the same function *) + false + | _ -> false + in + + let visitor = + object (self) + inherit [_] reduce_expression + method zero _ = false + method plus b0 b1 _ = b0 () && b1 () + + method! visit_texpression env e = + match e.e with + | Var _ | Const _ -> fun _ -> false + | Let (_, _, re, e) -> ( + match opt_destruct_function_call re with + | None -> fun () -> self#visit_texpression env e () + | Some (func1, tys1, args1) -> + let call_is_child = check_call func1 tys1 args1 in + if call_is_child then fun () -> true + else fun () -> self#visit_texpression env e ()) + | App _ -> ( + fun () -> + match opt_destruct_function_call e with + | Some (func1, tys1, args1) -> check_call func1 tys1 args1 + | None -> false) + | Abs (_, e) -> self#visit_texpression env e + | Qualif _ -> + (* Note that this case includes functions without arguments *) + fun () -> false + | Meta (_, e) -> self#visit_texpression env e + | Switch (_, body) -> self#visit_switch_body env body + + method! visit_switch_body env body = + match body with + | If (e1, e2) -> + fun () -> + self#visit_texpression env e1 () + && self#visit_texpression env e2 () + | Match branches -> + fun () -> + List.for_all + (fun br -> self#visit_texpression env br.branch ()) + branches + end + in + visitor#visit_texpression () e () + +(** Filter the useless assignments (removes the useless variables, filters + the function calls) *) +let filter_useless (filter_monadic_calls : bool) (ctx : trans_ctx) + (def : fun_decl) : fun_decl = + (* We first need a transformation on *left-values*, which filters the useless + * variables and tells us whether the value contains any variable which has + * not been replaced by [_] (in which case we need to keep the assignment, + * etc.). + * + * This is implemented as a map-reduce. + * + * Returns: ( filtered_left_value, *all_dummies* ) + * + * [all_dummies]: + * If the returned boolean is true, it means that all the variables appearing + * in the filtered left-value are *dummies* (meaning that if this left-value + * appears at the left of a let-binding, this binding might potentially be + * removed). + *) + let lv_visitor = + object + inherit [_] mapreduce_typed_pattern + method zero _ = true + method plus b0 b1 _ = b0 () && b1 () + + method! visit_PatVar env v mp = + if VarId.Set.mem v.id env then (PatVar (v, mp), fun _ -> false) + else (PatDummy, fun _ -> true) + end + in + let filter_typed_pattern (used_vars : VarId.Set.t) (lv : typed_pattern) : + typed_pattern * bool = + let lv, all_dummies = lv_visitor#visit_typed_pattern used_vars lv in + (lv, all_dummies ()) + in + + (* We then implement the transformation on *expressions* through a mapreduce. + * Note that the transformation is bottom-up. + * The map filters the useless assignments, the reduce computes the set of + * used variables. + *) + let expr_visitor = + object (self) + inherit [_] mapreduce_expression as super + method zero _ = VarId.Set.empty + method plus s0 s1 _ = VarId.Set.union (s0 ()) (s1 ()) + + (** Whenever we visit a variable, we need to register the used variable *) + method! visit_Var _ vid = (Var vid, fun _ -> VarId.Set.singleton vid) + + method! visit_expression env e = + match e with + | Var _ | Const _ | App _ | Qualif _ + | Switch (_, _) + | Meta (_, _) + | Abs _ -> + super#visit_expression env e + | Let (monadic, lv, re, e) -> + (* Compute the set of values used in the next expression *) + let e, used = self#visit_texpression env e in + let used = used () in + (* Filter the left values *) + let lv, all_dummies = filter_typed_pattern used lv in + (* Small utility - called if we can't filter the let-binding *) + let dont_filter () = + let re, used_re = self#visit_texpression env re in + let used = VarId.Set.union used (used_re ()) in + (Let (monadic, lv, re, e), fun _ -> used) + in + (* Potentially filter the let-binding *) + if all_dummies then + if not monadic then + (* Not a monadic let-binding: simple case *) + (e.e, fun _ -> used) + else + (* Monadic let-binding: trickier. + * We can filter if the right-expression is a function call, + * under some conditions. *) + match (filter_monadic_calls, opt_destruct_function_call re) with + | true, Some (func, tys, args) -> + (* We need to check if there is a child call - see + * the comments for: + * [expression_contains_child_call_in_all_paths] *) + let has_child_call = + expression_contains_child_call_in_all_paths ctx func tys + args e + in + if has_child_call then (* Filter *) + (e.e, fun _ -> used) + else (* No child call: don't filter *) + dont_filter () + | _ -> + (* Not a call or not allowed to filter: we can't filter *) + dont_filter () + else (* There are used variables: don't filter *) + dont_filter () + end + in + (* We filter only inside of transparent (i.e., non-opaque) definitions *) + match def.body with + | None -> def + | Some body -> + (* Visit the body *) + let body_exp, used_vars = expr_visitor#visit_texpression () body.body in + (* Visit the parameters - TODO: update: we can filter only if the definition + * is not recursive (otherwise it might mess up with the decrease clauses: + * the decrease clauses uses all the inputs given to the function, if some + * inputs are replaced by '_' we can't give it to the function used in the + * decreases clause). + * For now we deactivate the filtering. *) + let used_vars = used_vars () in + let inputs_lvs = + if false then + List.map + (fun lv -> fst (filter_typed_pattern used_vars lv)) + body.inputs_lvs + else body.inputs_lvs + in + (* Return *) + let body = { body with body = body_exp; inputs_lvs } in + { def with body = Some body } + +(** Simplify the aggregated ADTs. + Ex.: + {[ + type struct = { f0 : nat; f1 : nat } + + Mkstruct x.f0 x.f1 ~~> x + ]} + + TODO: introduce a notation for [{ x with field = ... }], and use it. + *) +let simplify_aggregates (ctx : trans_ctx) (def : fun_decl) : fun_decl = + let expr_visitor = + object + inherit [_] map_expression as super + + (* Look for a type constructor applied to arguments *) + method! visit_texpression env e = + match e.e with + | App _ -> ( + let app, args = destruct_apps e in + match app.e with + | Qualif + { + id = AdtCons { adt_id = AdtId adt_id; variant_id = None }; + type_args; + } -> + (* This is a struct *) + (* Retrieve the definiton, to find how many fields there are *) + let adt_decl = + TypeDeclId.Map.find adt_id ctx.type_context.type_decls + in + let fields = + match adt_decl.kind with + | Enum _ | Opaque -> raise (Failure "Unreachable") + | Struct fields -> fields + in + let num_fields = List.length fields in + (* In order to simplify, there must be as many arguments as + * there are fields *) + assert (num_fields > 0); + if num_fields = List.length args then + (* We now need to check that all the arguments are of the form: + * [x.field] for some variable [x], and where the projection + * is for the proper ADT *) + let to_var_proj (i : int) (arg : texpression) : + (ty list * var_id) option = + match arg.e with + | App (proj, x) -> ( + match (proj.e, x.e) with + | ( Qualif + { + id = + Proj { adt_id = AdtId proj_adt_id; field_id }; + type_args = proj_type_args; + }, + Var v ) -> + (* We check that this is the proper ADT, and the proper field *) + if + proj_adt_id = adt_id + && FieldId.to_int field_id = i + then Some (proj_type_args, v) + else None + | _ -> None) + | _ -> None + in + let args = List.mapi to_var_proj args in + let args = List.filter_map (fun x -> x) args in + (* Check that all the arguments are of the expected form *) + if List.length args = num_fields then + (* Check that this is the same variable we project from - + * note that we checked above that there is at least one field *) + let (_, x), end_args = Collections.List.pop args in + if List.for_all (fun (_, y) -> y = x) end_args then ( + (* We can substitute *) + (* Sanity check: all types correct *) + assert ( + List.for_all (fun (tys, _) -> tys = type_args) args); + { e with e = Var x }) + else super#visit_texpression env e + else super#visit_texpression env e + else super#visit_texpression env e + | _ -> super#visit_texpression env e) + | _ -> super#visit_texpression env e + end + in + match def.body with + | None -> def + | Some body -> + (* Visit the body *) + let body_exp = expr_visitor#visit_texpression () body.body in + (* Return *) + let body = { body with body = body_exp } in + { def with body = Some body } + +(** Return [None] if the function is a backward function with no outputs (so + that we eliminate the definition which is useless). + + Note that the calls to such functions are filtered when translating from + symbolic to pure. Here, we remove the definitions altogether, because they + are now useless + *) +let filter_if_backward_with_no_outputs (config : config) (def : fun_decl) : + fun_decl option = + if + config.filter_useless_functions && Option.is_some def.back_id + && def.signature.output = mk_result_ty mk_unit_ty + then None + else Some def + +(** Return [false] if the forward function is useless and should be filtered. + + - a forward function with no output (comes from a Rust function with + unit return type) + - the function has mutable borrows as inputs (which is materialized + by the fact we generated backward functions which were not filtered). + + In such situation, every call to the Rust function will be translated to: + - a call to the forward function which returns nothing + - calls to the backward functions + As a failing backward function implies the forward function also fails, + we can filter the calls to the forward function, which thus becomes + useless. + In such situation, we can remove the forward function definition + altogether. + *) +let keep_forward (config : config) (trans : pure_fun_translation) : bool = + let fwd, backs = trans in + (* Note that at this point, the output types are no longer seen as tuples: + * they should be lists of length 1. *) + if + config.filter_useless_functions + && fwd.signature.output = mk_result_ty mk_unit_ty + && backs <> [] + then false + else true + +(** Convert the unit variables to [()] if they are used as right-values or + [_] if they are used as left values in patterns. *) +let unit_vars_to_unit (def : fun_decl) : fun_decl = + (* The map visitor *) + let obj = + object + inherit [_] map_expression as super + + (** Replace in patterns *) + method! visit_PatVar _ v mp = + if v.ty = mk_unit_ty then PatDummy else PatVar (v, mp) + + (** Replace in "regular" expressions - note that we could limit ourselves + to variables, but this is more powerful + *) + method! visit_texpression env e = + if e.ty = mk_unit_ty then mk_unit_rvalue + else super#visit_texpression env e + end + in + (* Update the body *) + match def.body with + | None -> def + | Some body -> + let body_exp = obj#visit_texpression () body.body in + (* Update the input parameters *) + let inputs_lvs = List.map (obj#visit_typed_pattern ()) body.inputs_lvs in + (* Return *) + let body = Some { body with body = body_exp; inputs_lvs } in + { def with body } + +(** Eliminate the box functions like [Box::new], [Box::deref], etc. Most of them + are translated to identity, and [Box::free] is translated to [()]. + + Note that the box types have already been eliminated during the translation + from symbolic to pure. + The reason why we don't eliminate the box functions at the same time is + that we would need to eliminate them in two different places: when translating + function calls, and when translating end abstractions. Here, we can do + something simpler, in one micro-pass. + *) +let eliminate_box_functions (_ctx : trans_ctx) (def : fun_decl) : fun_decl = + (* The map visitor *) + let obj = + object + inherit [_] map_expression as super + + method! visit_texpression env e = + match opt_destruct_function_call e with + | Some (fun_id, _tys, args) -> ( + match fun_id with + | Regular (A.Assumed aid, rg_id) -> ( + (* Below, when dealing with the arguments: we consider the very + * general case, where functions could be boxed (meaning we + * could have: [box_new f x]) + * *) + match (aid, rg_id) with + | A.BoxNew, _ -> + assert (rg_id = None); + let arg, args = Collections.List.pop args in + mk_apps arg args + | A.BoxDeref, None -> + (* [Box::deref] forward is the identity *) + let arg, args = Collections.List.pop args in + mk_apps arg args + | A.BoxDeref, Some _ -> + (* [Box::deref] backward is [()] (doesn't give back anything) *) + assert (args = []); + mk_unit_rvalue + | A.BoxDerefMut, None -> + (* [Box::deref_mut] forward is the identity *) + let arg, args = Collections.List.pop args in + mk_apps arg args + | A.BoxDerefMut, Some _ -> + (* [Box::deref_mut] back is almost the identity: + * let box_deref_mut (x_init : t) (x_back : t) : t = x_back + * *) + let arg, args = + match args with + | _ :: given_back :: args -> (given_back, args) + | _ -> failwith "Unreachable" + in + mk_apps arg args + | A.BoxFree, _ -> + assert (args = []); + mk_unit_rvalue + | ( ( A.Replace | A.VecNew | A.VecPush | A.VecInsert | A.VecLen + | A.VecIndex | A.VecIndexMut ), + _ ) -> + super#visit_texpression env e) + | _ -> super#visit_texpression env e) + | _ -> super#visit_texpression env e + end + in + (* Update the body *) + match def.body with + | None -> def + | Some body -> + let body = Some { body with body = obj#visit_texpression () body.body } in + { def with body } + +(** Decompose the monadic let-bindings. + + See the explanations in [config]. + *) +let decompose_monadic_let_bindings (_ctx : trans_ctx) (def : fun_decl) : + fun_decl = + match def.body with + | None -> def + | Some body -> + (* Set up the var id generator *) + let cnt = get_body_min_var_counter body in + let _, fresh_id = VarId.mk_stateful_generator cnt in + (* It is a very simple map *) + let obj = + object (self) + inherit [_] map_expression as super + + method! visit_Let env monadic lv re next_e = + if not monadic then super#visit_Let env monadic lv re next_e + else + (* If monadic, we need to check if the left-value is a variable: + * - if yes, don't decompose + * - if not, make the decomposition in two steps + *) + match lv.value with + | PatVar _ -> + (* Variable: nothing to do *) + super#visit_Let env monadic lv re next_e + | _ -> + (* Not a variable: decompose *) + (* Introduce a temporary variable to receive the value of the + * monadic binding *) + let vid = fresh_id () in + let tmp : var = { id = vid; basename = None; ty = lv.ty } in + let ltmp = mk_typed_pattern_from_var tmp None in + let rtmp = mk_texpression_from_var tmp in + (* Visit the next expression *) + let next_e = self#visit_texpression env next_e in + (* Create the let-bindings *) + (mk_let true ltmp re (mk_let false lv rtmp next_e)).e + end + in + (* Update the body *) + let body = Some { body with body = obj#visit_texpression () body.body } in + (* Return *) + { def with body } + +(** Unfold the monadic let-bindings to explicit matches. *) +let unfold_monadic_let_bindings (_ctx : trans_ctx) (def : fun_decl) : fun_decl = + match def.body with + | None -> def + | Some body -> + (* It is a very simple map *) + let obj = + object (_self) + inherit [_] map_expression as super + + method! visit_Let env monadic lv re e = + (* We simply do the following transformation: + {[ + pat <-- re; e + + ~~> + + match re with + | Fail err -> Fail err + | Return pat -> e + ]} + *) + (* TODO: we should use a monad "kind" instead of a boolean *) + if not monadic then super#visit_Let env monadic lv re e + else + (* We don't do the same thing if we use a state-error monad or simply + an error monad. + Note that some functions always live in the error monad (arithmetic + operations, for instance). + *) + (* TODO: this information should be computed in SymbolicToPure and + * store in an enum ("monadic" should be an enum, not a bool). *) + let re_ty = Option.get (opt_destruct_result re.ty) in + assert (lv.ty = re_ty); + let fail_pat = mk_result_fail_pattern lv.ty in + let fail_value = mk_result_fail_texpression e.ty in + let fail_branch = { pat = fail_pat; branch = fail_value } in + let success_pat = mk_result_return_pattern lv in + let success_branch = { pat = success_pat; branch = e } in + let switch_body = Match [ fail_branch; success_branch ] in + let e = Switch (re, switch_body) in + (* Continue *) + super#visit_expression env e + end + in + (* Update the body *) + let body_e = obj#visit_texpression () body.body in + let body = { body with body = body_e } in + (* Return *) + { def with body = Some body } + +(** Apply all the micro-passes to a function. + + Will return [None] if the function is a backward function with no outputs. + + [ctx]: used only for printing. + *) +let apply_passes_to_def (config : config) (ctx : trans_ctx) (def : fun_decl) : + fun_decl option = + (* Debug *) + log#ldebug + (lazy + ("PureMicroPasses.apply_passes_to_def: " + ^ Print.fun_name_to_string def.basename + ^ " (" + ^ Print.option_to_string T.RegionGroupId.to_string def.back_id + ^ ")")); + + (* First, find names for the variables which are unnamed *) + let def = compute_pretty_names def in + log#ldebug + (lazy ("compute_pretty_name:\n\n" ^ fun_decl_to_string ctx def ^ "\n")); + + (* TODO: we might want to leverage more the assignment meta-data, for + * aggregates for instance. *) + + (* TODO: reorder the branches of the matches/switches *) + + (* The meta-information is now useless: remove it. + * Rk.: some passes below use the fact that we removed the meta-data + * (otherwise we would have to "unmeta" expressions before matching) *) + let def = remove_meta def in + log#ldebug (lazy ("remove_meta:\n\n" ^ fun_decl_to_string ctx def ^ "\n")); + + (* Remove the backward functions with no outputs. + * Note that the calls to those functions should already have been removed, + * when translating from symbolic to pure. Here, we remove the definitions + * altogether, because they are now useless *) + let def = filter_if_backward_with_no_outputs config def in + + match def with + | None -> None + | Some def -> + (* Convert the unit variables to [()] if they are used as right-values or + * [_] if they are used as left values. *) + let def = unit_vars_to_unit def in + log#ldebug + (lazy ("unit_vars_to_unit:\n\n" ^ fun_decl_to_string ctx def ^ "\n")); + + (* Inline the useless variable reassignments *) + let inline_named_vars = true in + let inline_pure = true in + let def = + inline_useless_var_reassignments inline_named_vars inline_pure def + in + log#ldebug + (lazy + ("inline_useless_var_assignments:\n\n" ^ fun_decl_to_string ctx def + ^ "\n")); + + (* Eliminate the box functions - note that the "box" types were eliminated + * during the symbolic to pure phase: see the comments for [eliminate_box_functions] *) + let def = eliminate_box_functions ctx def in + log#ldebug + (lazy + ("eliminate_box_functions:\n\n" ^ fun_decl_to_string ctx def ^ "\n")); + + (* Filter the useless variables, assignments, function calls, etc. *) + let def = filter_useless config.filter_useless_monadic_calls ctx def in + log#ldebug + (lazy ("filter_useless:\n\n" ^ fun_decl_to_string ctx def ^ "\n")); + + (* Simplify the aggregated ADTs. + Ex.: + {[ + type struct = { f0 : nat; f1 : nat } + + Mkstruct x.f0 x.f1 ~~> x + ]} + *) + let def = simplify_aggregates ctx def in + log#ldebug + (lazy ("simplify_aggregates:\n\n" ^ fun_decl_to_string ctx def ^ "\n")); + + (* Decompose the monadic let-bindings - F* specific + * TODO: remove? *) + let def = + if config.decompose_monadic_let_bindings then ( + let def = decompose_monadic_let_bindings ctx def in + log#ldebug + (lazy + ("decompose_monadic_let_bindings:\n\n" + ^ fun_decl_to_string ctx def ^ "\n")); + def) + else ( + log#ldebug + (lazy + "ignoring decompose_monadic_let_bindings due to the configuration\n"); + def) + in + + (* Unfold the monadic let-bindings *) + let def = + if config.unfold_monadic_let_bindings then ( + let def = unfold_monadic_let_bindings ctx def in + log#ldebug + (lazy + ("unfold_monadic_let_bindings:\n\n" ^ fun_decl_to_string ctx def + ^ "\n")); + def) + else ( + log#ldebug + (lazy + "ignoring unfold_monadic_let_bindings due to the configuration\n"); + def) + in + + (* We are done *) + Some def + +(** Return the forward/backward translations on which we applied the micro-passes. + + Also returns a boolean indicating whether the forward function should be kept + or not (because useful/useless - [true] means we need to keep the forward + function). + Note that we don't "filter" the forward function and return a boolean instead, + because this function contains useful information to extract the backward + functions: keeping it is not necessary but more convenient. + *) +let apply_passes_to_pure_fun_translation (config : config) (ctx : trans_ctx) + (trans : pure_fun_translation) : bool * pure_fun_translation = + (* Apply the passes to the individual functions *) + let forward, backwards = trans in + let forward = Option.get (apply_passes_to_def config ctx forward) in + let backwards = List.filter_map (apply_passes_to_def config ctx) backwards in + let trans = (forward, backwards) in + (* Compute whether we need to filter the forward function or not *) + (keep_forward config trans, trans) diff --git a/compiler/PureToExtract.ml b/compiler/PureToExtract.ml new file mode 100644 index 00000000..77c3afd4 --- /dev/null +++ b/compiler/PureToExtract.ml @@ -0,0 +1,723 @@ +(** This module is used to extract the pure ASTs to various theorem provers. + It defines utilities and helpers to make the work as easy as possible: + we try to factorize as much as possible the different extractions to the + backends we target. + *) + +open Pure +open TranslateCore +module C = Contexts +module RegionVarId = T.RegionVarId +module F = Format + +(** The local logger *) +let log = L.pure_to_extract_log + +type region_group_info = { + id : RegionGroupId.id; + (** The id of the region group. + Note that a simple way of generating unique names for backward + functions is to use the region group ids. + *) + region_names : string option list; + (** The names of the region variables included in this group. + Note that names are not always available... + *) +} + +module StringSet = Collections.MakeSet (Collections.OrderedString) +module StringMap = Collections.MakeMap (Collections.OrderedString) + +type name = Names.name +type type_name = Names.type_name +type global_name = Names.global_name +type fun_name = Names.fun_name + +(* TODO: this should a module we give to a functor! *) + +(** A formatter's role is twofold: + 1. Come up with name suggestions. + For instance, provided some information about a function (its basename, + information about the region group, etc.) it should come up with an + appropriate name for the forward/backward function. + + It can of course apply many transformations, like changing to camel case/ + snake case, adding prefixes/suffixes, etc. + + 2. Format some specific terms, like constants. + *) +type formatter = { + bool_name : string; + char_name : string; + int_name : integer_type -> string; + str_name : string; + field_name : name -> FieldId.id -> string option -> string; + (** Inputs: + - type name + - field id + - field name + + Note that fields don't always have names, but we still need to + generate some names if we want to extract the structures to records... + We might want to extract such structures to tuples, later, but field + access then causes trouble because not all provers accept syntax like + [x.3] where [x] is a tuple. + *) + variant_name : name -> string -> string; + (** Inputs: + - type name + - variant name + *) + struct_constructor : name -> string; + (** Structure constructors are used when constructing structure values. + + For instance, in F*: + {[ + type pair = { x : nat; y : nat } + let p : pair = Mkpair 0 1 + ]} + + Inputs: + - type name + *) + type_name : type_name -> string; + (** Provided a basename, compute a type name. *) + global_name : global_name -> string; + (** Provided a basename, compute a global name. *) + fun_name : + A.fun_id -> + fun_name -> + int -> + region_group_info option -> + bool * int -> + string; + (** Inputs: + - function id: this is especially useful to identify whether the + function is an assumed function or a local function + - function basename + - number of region groups + - region group information in case of a backward function + ([None] if forward function) + - pair: + - do we generate the forward function (it may have been filtered)? + - the number of extracted backward functions (not necessarily equal + to the number of region groups, because we may have filtered + some of them) + TODO: use the fun id for the assumed functions. + *) + decreases_clause_name : A.FunDeclId.id -> fun_name -> string; + (** Generates the name of the definition used to prove/reason about + termination. The generated code uses this clause where needed, + but its body must be defined by the user. + + Inputs: + - function id: this is especially useful to identify whether the + function is an assumed function or a local function + - function basename + *) + var_basename : StringSet.t -> string option -> ty -> string; + (** Generates a variable basename. + + Inputs: + - the set of names used in the context so far + - the basename we got from the symbolic execution, if we have one + - the type of the variable (can be useful for heuristics, in order + not to always use "x" for instance, whenever naming anonymous + variables) + + Note that once the formatter generated a basename, we add an index + if necessary to prevent name clashes: the burden of name clashes checks + is thus on the caller's side. + *) + type_var_basename : StringSet.t -> string -> string; + (** Generates a type variable basename. *) + append_index : string -> int -> string; + (** Appends an index to a name - we use this to generate unique + names: when doing so, the role of the formatter is just to concatenate + indices to names, the responsability of finding a proper index is + delegated to helper functions. + *) + extract_constant_value : F.formatter -> bool -> constant_value -> unit; + (** Format a constant value. + + Inputs: + - formatter + - [inside]: if [true], the value should be wrapped in parentheses + if it is made of an application (ex.: [U32 3]) + - the constant value + *) + extract_unop : + (bool -> texpression -> unit) -> + F.formatter -> + bool -> + unop -> + texpression -> + unit; + (** Format a unary operation + + Inputs: + - a formatter for expressions (called on the argument of the unop) + - extraction context (see below) + - formatter + - expression formatter + - [inside] + - unop + - argument + *) + extract_binop : + (bool -> texpression -> unit) -> + F.formatter -> + bool -> + E.binop -> + integer_type -> + texpression -> + texpression -> + unit; + (** Format a binary operation + + Inputs: + - a formatter for expressions (called on the arguments of the binop) + - extraction context (see below) + - formatter + - expression formatter + - [inside] + - binop + - argument 0 + - argument 1 + *) +} + +(** We use identifiers to look for name clashes *) +type id = + | GlobalId of A.GlobalDeclId.id + | FunId of A.fun_id * RegionGroupId.id option + | DecreasesClauseId of A.fun_id + (** The definition which provides the decreases/termination clause. + We insert calls to this clause to prove/reason about termination: + the body of those clauses must be defined by the user, in the + proper files. + *) + | TypeId of type_id + | StructId of type_id + (** We use this when we manipulate the names of the structure + constructors. + + For instance, in F*: + {[ + type pair = { x: nat; y : nat } + let p : pair = Mkpair 0 1 + ]} + *) + | VariantId of type_id * VariantId.id + (** If often happens that variant names must be unique (it is the case in + F* ) which is why we register them here. + *) + | FieldId of type_id * FieldId.id + (** If often happens that in the case of structures, the field names + must be unique (it is the case in F* ) which is why we register + them here. + *) + | TypeVarId of TypeVarId.id + | VarId of VarId.id + | UnknownId + (** Used for stored various strings like keywords, definitions which + should always be in context, etc. and which can't be linked to one + of the above. + *) +[@@deriving show, ord] + +module IdOrderedType = struct + type t = id + + let compare = compare_id + let to_string = show_id + let pp_t = pp_id + let show_t = show_id +end + +module IdMap = Collections.MakeMap (IdOrderedType) + +(** The names map stores the mappings from names to identifiers and vice-versa. + + We use it for lookups (during the translation) and to check for name clashes. + + [id_to_string] is for debugging. + *) +type names_map = { + id_to_name : string IdMap.t; + name_to_id : id StringMap.t; + (** The name to id map is used to look for name clashes, and generate nice + debugging messages: if there is a name clash, it is useful to know + precisely which identifiers are mapped to the same name... + *) + names_set : StringSet.t; +} + +let names_map_add (id_to_string : id -> string) (id : id) (name : string) + (nm : names_map) : names_map = + (* Check if there is a clash *) + (match StringMap.find_opt name nm.name_to_id with + | None -> () (* Ok *) + | Some clash -> + (* There is a clash: print a nice debugging message for the user *) + let id1 = "\n- " ^ id_to_string clash in + let id2 = "\n- " ^ id_to_string id in + let err = + "Name clash detected: the following identifiers are bound to the same \ + name \"" ^ name ^ "\":" ^ id1 ^ id2 + in + log#serror err; + failwith err); + (* Sanity check *) + assert (not (StringSet.mem name nm.names_set)); + (* Insert *) + let id_to_name = IdMap.add id name nm.id_to_name in + let name_to_id = StringMap.add name id nm.name_to_id in + let names_set = StringSet.add name nm.names_set in + { id_to_name; name_to_id; names_set } + +let names_map_add_assumed_type (id_to_string : id -> string) (id : assumed_ty) + (name : string) (nm : names_map) : names_map = + names_map_add id_to_string (TypeId (Assumed id)) name nm + +let names_map_add_assumed_struct (id_to_string : id -> string) (id : assumed_ty) + (name : string) (nm : names_map) : names_map = + names_map_add id_to_string (StructId (Assumed id)) name nm + +let names_map_add_assumed_variant (id_to_string : id -> string) + (id : assumed_ty) (variant_id : VariantId.id) (name : string) + (nm : names_map) : names_map = + names_map_add id_to_string (VariantId (Assumed id, variant_id)) name nm + +let names_map_add_assumed_function (id_to_string : id -> string) + (fid : A.assumed_fun_id) (rg_id : RegionGroupId.id option) (name : string) + (nm : names_map) : names_map = + names_map_add id_to_string (FunId (A.Assumed fid, rg_id)) name nm + +(** Make a (variable) basename unique (by adding an index). + + We do this in an inefficient manner (by testing all indices starting from + 0) but it shouldn't be a bottleneck. + + Also note that at some point, we thought about trying to reuse names of + variables which are not used anymore, like here: + {[ + let x = ... in + ... + let x0 = ... in // We could use the name "x" if [x] is not used below + ... + ]} + + However it is a good idea to keep things as they are for F*: as F* is + designed for extrinsic proofs, a proof about a function follows this + function's structure. The consequence is that we often end up + copy-pasting function bodies. As in the proofs (in assertions and + when calling lemmas) we often need to talk about the "past" (i.e., + previous values), it is very useful to generate code where all variable + names are assigned at most once. + + [append]: function to append an index to a string + *) +let basename_to_unique (names_set : StringSet.t) + (append : string -> int -> string) (basename : string) : string = + let rec gen (i : int) : string = + let s = append basename i in + if StringSet.mem s names_set then gen (i + 1) else s + in + if StringSet.mem basename names_set then gen 0 else basename + +(** Extraction context. + + Note that the extraction context contains information coming from the + LLBC AST (not only the pure AST). This is useful for naming, for instance: + we use the region information to generate the names of the backward + functions, etc. + *) +type extraction_ctx = { + trans_ctx : trans_ctx; + names_map : names_map; + fmt : formatter; + indent_incr : int; + (** The indent increment we insert whenever we need to indent more *) +} + +(** Debugging function *) +let id_to_string (id : id) (ctx : extraction_ctx) : string = + let global_decls = ctx.trans_ctx.global_context.global_decls in + let fun_decls = ctx.trans_ctx.fun_context.fun_decls in + let type_decls = ctx.trans_ctx.type_context.type_decls in + (* TODO: factorize the pretty-printing with what is in PrintPure *) + let get_type_name (id : type_id) : string = + match id with + | AdtId id -> + let def = TypeDeclId.Map.find id type_decls in + Print.name_to_string def.name + | Assumed aty -> show_assumed_ty aty + | Tuple -> failwith "Unreachable" + in + match id with + | GlobalId gid -> + let name = (A.GlobalDeclId.Map.find gid global_decls).name in + "global name: " ^ Print.global_name_to_string name + | FunId (fid, rg_id) -> + let fun_name = + match fid with + | A.Regular fid -> + Print.fun_name_to_string (A.FunDeclId.Map.find fid fun_decls).name + | A.Assumed aid -> A.show_assumed_fun_id aid + in + let fun_kind = + match rg_id with + | None -> "forward" + | Some rg_id -> "backward " ^ RegionGroupId.to_string rg_id + in + "fun name (" ^ fun_kind ^ "): " ^ fun_name + | DecreasesClauseId fid -> + let fun_name = + match fid with + | A.Regular fid -> + Print.fun_name_to_string (A.FunDeclId.Map.find fid fun_decls).name + | A.Assumed aid -> A.show_assumed_fun_id aid + in + "decreases clause for function: " ^ fun_name + | TypeId id -> "type name: " ^ get_type_name id + | StructId id -> "struct constructor of: " ^ get_type_name id + | VariantId (id, variant_id) -> + let variant_name = + match id with + | Tuple -> failwith "Unreachable" + | Assumed State -> failwith "Unreachable" + | Assumed Result -> + if variant_id = result_return_id then "@result::Return" + else if variant_id = result_fail_id then "@result::Fail" + else failwith "Unreachable" + | Assumed Option -> + if variant_id = option_some_id then "@option::Some" + else if variant_id = option_none_id then "@option::None" + else failwith "Unreachable" + | Assumed Vec -> failwith "Unreachable" + | AdtId id -> ( + let def = TypeDeclId.Map.find id type_decls in + match def.kind with + | Struct _ | Opaque -> failwith "Unreachable" + | Enum variants -> + let variant = VariantId.nth variants variant_id in + Print.name_to_string def.name ^ "::" ^ variant.variant_name) + in + "variant name: " ^ variant_name + | FieldId (id, field_id) -> + let field_name = + match id with + | Tuple -> failwith "Unreachable" + | Assumed (State | Result | Option) -> failwith "Unreachable" + | Assumed Vec -> + (* We can't directly have access to the fields of a vector *) + failwith "Unreachable" + | AdtId id -> ( + let def = TypeDeclId.Map.find id type_decls in + match def.kind with + | Enum _ | Opaque -> failwith "Unreachable" + | Struct fields -> + let field = FieldId.nth fields field_id in + let field_name = + match field.field_name with + | None -> FieldId.to_string field_id + | Some name -> name + in + Print.name_to_string def.name ^ "." ^ field_name) + in + "field name: " ^ field_name + | UnknownId -> "keyword" + | TypeVarId _ | VarId _ -> + (* We should never get there: we add indices to make sure variable + * names are unique *) + failwith "Unreachable" + +let ctx_add (id : id) (name : string) (ctx : extraction_ctx) : extraction_ctx = + (* The id_to_string function to print nice debugging messages if there are + * collisions *) + let id_to_string (id : id) : string = id_to_string id ctx in + let names_map = names_map_add id_to_string id name ctx.names_map in + { ctx with names_map } + +let ctx_get (id : id) (ctx : extraction_ctx) : string = + match IdMap.find_opt id ctx.names_map.id_to_name with + | Some s -> s + | None -> + log#serror ("Could not find: " ^ id_to_string id ctx); + raise Not_found + +let ctx_get_global (id : A.GlobalDeclId.id) (ctx : extraction_ctx) : string = + ctx_get (GlobalId id) ctx + +let ctx_get_function (id : A.fun_id) (rg : RegionGroupId.id option) + (ctx : extraction_ctx) : string = + ctx_get (FunId (id, rg)) ctx + +let ctx_get_local_function (id : A.FunDeclId.id) (rg : RegionGroupId.id option) + (ctx : extraction_ctx) : string = + ctx_get_function (A.Regular id) rg ctx + +let ctx_get_type (id : type_id) (ctx : extraction_ctx) : string = + assert (id <> Tuple); + ctx_get (TypeId id) ctx + +let ctx_get_local_type (id : TypeDeclId.id) (ctx : extraction_ctx) : string = + ctx_get_type (AdtId id) ctx + +let ctx_get_assumed_type (id : assumed_ty) (ctx : extraction_ctx) : string = + ctx_get_type (Assumed id) ctx + +let ctx_get_var (id : VarId.id) (ctx : extraction_ctx) : string = + ctx_get (VarId id) ctx + +let ctx_get_type_var (id : TypeVarId.id) (ctx : extraction_ctx) : string = + ctx_get (TypeVarId id) ctx + +let ctx_get_field (type_id : type_id) (field_id : FieldId.id) + (ctx : extraction_ctx) : string = + ctx_get (FieldId (type_id, field_id)) ctx + +let ctx_get_struct (def_id : type_id) (ctx : extraction_ctx) : string = + ctx_get (StructId def_id) ctx + +let ctx_get_variant (def_id : type_id) (variant_id : VariantId.id) + (ctx : extraction_ctx) : string = + ctx_get (VariantId (def_id, variant_id)) ctx + +let ctx_get_decreases_clause (def_id : A.FunDeclId.id) (ctx : extraction_ctx) : + string = + ctx_get (DecreasesClauseId (A.Regular def_id)) ctx + +(** Generate a unique type variable name and add it to the context *) +let ctx_add_type_var (basename : string) (id : TypeVarId.id) + (ctx : extraction_ctx) : extraction_ctx * string = + let name = ctx.fmt.type_var_basename ctx.names_map.names_set basename in + let name = + basename_to_unique ctx.names_map.names_set ctx.fmt.append_index name + in + let ctx = ctx_add (TypeVarId id) name ctx in + (ctx, name) + +(** See {!ctx_add_type_var} *) +let ctx_add_type_vars (vars : (string * TypeVarId.id) list) + (ctx : extraction_ctx) : extraction_ctx * string list = + List.fold_left_map + (fun ctx (name, id) -> ctx_add_type_var name id ctx) + ctx vars + +(** Generate a unique variable name and add it to the context *) +let ctx_add_var (basename : string) (id : VarId.id) (ctx : extraction_ctx) : + extraction_ctx * string = + let name = + basename_to_unique ctx.names_map.names_set ctx.fmt.append_index basename + in + let ctx = ctx_add (VarId id) name ctx in + (ctx, name) + +(** See {!ctx_add_var} *) +let ctx_add_vars (vars : var list) (ctx : extraction_ctx) : + extraction_ctx * string list = + List.fold_left_map + (fun ctx (v : var) -> + let name = ctx.fmt.var_basename ctx.names_map.names_set v.basename v.ty in + ctx_add_var name v.id ctx) + ctx vars + +let ctx_add_type_params (vars : type_var list) (ctx : extraction_ctx) : + extraction_ctx * string list = + List.fold_left_map + (fun ctx (var : type_var) -> ctx_add_type_var var.name var.index ctx) + ctx vars + +let ctx_add_type_decl_struct (def : type_decl) (ctx : extraction_ctx) : + extraction_ctx * string = + let cons_name = ctx.fmt.struct_constructor def.name in + let ctx = ctx_add (StructId (AdtId def.def_id)) cons_name ctx in + (ctx, cons_name) + +let ctx_add_type_decl (def : type_decl) (ctx : extraction_ctx) : extraction_ctx + = + let def_name = ctx.fmt.type_name def.name in + let ctx = ctx_add (TypeId (AdtId def.def_id)) def_name ctx in + ctx + +let ctx_add_field (def : type_decl) (field_id : FieldId.id) (field : field) + (ctx : extraction_ctx) : extraction_ctx * string = + let name = ctx.fmt.field_name def.name field_id field.field_name in + let ctx = ctx_add (FieldId (AdtId def.def_id, field_id)) name ctx in + (ctx, name) + +let ctx_add_fields (def : type_decl) (fields : (FieldId.id * field) list) + (ctx : extraction_ctx) : extraction_ctx * string list = + List.fold_left_map + (fun ctx (vid, v) -> ctx_add_field def vid v ctx) + ctx fields + +let ctx_add_variant (def : type_decl) (variant_id : VariantId.id) + (variant : variant) (ctx : extraction_ctx) : extraction_ctx * string = + let name = ctx.fmt.variant_name def.name variant.variant_name in + let ctx = ctx_add (VariantId (AdtId def.def_id, variant_id)) name ctx in + (ctx, name) + +let ctx_add_variants (def : type_decl) + (variants : (VariantId.id * variant) list) (ctx : extraction_ctx) : + extraction_ctx * string list = + List.fold_left_map + (fun ctx (vid, v) -> ctx_add_variant def vid v ctx) + ctx variants + +let ctx_add_struct (def : type_decl) (ctx : extraction_ctx) : + extraction_ctx * string = + let name = ctx.fmt.struct_constructor def.name in + let ctx = ctx_add (StructId (AdtId def.def_id)) name ctx in + (ctx, name) + +let ctx_add_decrases_clause (def : fun_decl) (ctx : extraction_ctx) : + extraction_ctx = + let name = ctx.fmt.decreases_clause_name def.def_id def.basename in + ctx_add (DecreasesClauseId (A.Regular def.def_id)) name ctx + +let ctx_add_global_decl_and_body (def : A.global_decl) (ctx : extraction_ctx) : + extraction_ctx = + let name = ctx.fmt.global_name def.name in + let decl = GlobalId def.def_id in + let body = FunId (Regular def.body_id, None) in + let ctx = ctx_add decl (name ^ "_c") ctx in + let ctx = ctx_add body (name ^ "_body") ctx in + ctx + +let ctx_add_fun_decl (trans_group : bool * pure_fun_translation) + (def : fun_decl) (ctx : extraction_ctx) : extraction_ctx = + (* Sanity check: the function should not be a global body - those are handled + * separately *) + assert (not def.is_global_decl_body); + (* Lookup the LLBC def to compute the region group information *) + let def_id = def.def_id in + let llbc_def = + A.FunDeclId.Map.find def_id ctx.trans_ctx.fun_context.fun_decls + in + let sg = llbc_def.signature in + let num_rgs = List.length sg.regions_hierarchy in + let keep_fwd, (_, backs) = trans_group in + let num_backs = List.length backs in + let rg_info = + match def.back_id with + | None -> None + | Some rg_id -> + let rg = T.RegionGroupId.nth sg.regions_hierarchy rg_id in + let regions = + List.map + (fun rid -> T.RegionVarId.nth sg.region_params rid) + rg.regions + in + let region_names = + List.map (fun (r : T.region_var) -> r.name) regions + in + Some { id = rg_id; region_names } + in + let def_id = A.Regular def_id in + let name = + ctx.fmt.fun_name def_id def.basename num_rgs rg_info (keep_fwd, num_backs) + in + ctx_add (FunId (def_id, def.back_id)) name ctx + +type names_map_init = { + keywords : string list; + assumed_adts : (assumed_ty * string) list; + assumed_structs : (assumed_ty * string) list; + assumed_variants : (assumed_ty * VariantId.id * string) list; + assumed_functions : (A.assumed_fun_id * RegionGroupId.id option * string) list; +} + +(** Initialize a names map with a proper set of keywords/names coming from the + target language/prover. *) +let initialize_names_map (init : names_map_init) : names_map = + let name_to_id = + StringMap.of_list (List.map (fun x -> (x, UnknownId)) init.keywords) + in + let names_set = StringSet.of_list init.keywords in + (* We fist initialize [id_to_name] as empty, because the id of a keyword is [UnknownId]. + * Also note that we don't need this mapping for keywords: we insert keywords only + * to check collisions. *) + let id_to_name = IdMap.empty in + let nm = { id_to_name; name_to_id; names_set } in + (* For debugging - we are creating bindings for assumed types and functions, so + * it is ok if we simply use the "show" function (those aren't simply identified + * by numbers) *) + let id_to_string = show_id in + (* Then we add: + * - the assumed types + * - the assumed struct constructors + * - the assumed variants + * - the assumed functions + *) + let nm = + List.fold_left + (fun nm (type_id, name) -> + names_map_add_assumed_type id_to_string type_id name nm) + nm init.assumed_adts + in + let nm = + List.fold_left + (fun nm (type_id, name) -> + names_map_add_assumed_struct id_to_string type_id name nm) + nm init.assumed_structs + in + let nm = + List.fold_left + (fun nm (type_id, variant_id, name) -> + names_map_add_assumed_variant id_to_string type_id variant_id name nm) + nm init.assumed_variants + in + let nm = + List.fold_left + (fun nm (fun_id, rg_id, name) -> + names_map_add_assumed_function id_to_string fun_id rg_id name nm) + nm init.assumed_functions + in + (* Return *) + nm + +let compute_type_decl_name (fmt : formatter) (def : type_decl) : string = + fmt.type_name def.name + +(** A helper function: generates a function suffix from a region group + information. + TODO: move all those helpers. +*) +let default_fun_suffix (num_region_groups : int) (rg : region_group_info option) + ((keep_fwd, num_backs) : bool * int) : string = + (* There are several cases: + - [rg] is [Some]: this is a forward function: + - we add "_fwd" + - [rg] is [None]: this is a backward function: + - this function has one extracted backward function: + - if the forward function has been filtered, we add "_fwd_back": + the forward function is useless, so the unique backward function + takes its place, in a way + - otherwise we add "_back" + - this function has several backward functions: we add "_back" and an + additional suffix to identify the precise backward function + Note that we always add a suffix (in case there are no region groups, + we could not add the "_fwd" suffix) to prevent name clashes between + definitions (in particular between type and function definitions). + *) + match rg with + | None -> "_fwd" + | Some rg -> + assert (num_region_groups > 0 && num_backs > 0); + if num_backs = 1 then + (* Exactly one backward function *) + if not keep_fwd then "_fwd_back" else "_back" + else if + (* Several region groups/backward functions: + - if all the regions in the group have names, we use those names + - otherwise we use an index + *) + List.for_all Option.is_some rg.region_names + then + (* Concatenate the region names *) + "_back" ^ String.concat "" (List.map Option.get rg.region_names) + else (* Use the region index *) + "_back" ^ RegionGroupId.to_string rg.id diff --git a/compiler/PureTypeCheck.ml b/compiler/PureTypeCheck.ml new file mode 100644 index 00000000..caad8a58 --- /dev/null +++ b/compiler/PureTypeCheck.ml @@ -0,0 +1,178 @@ +(** Module to perform type checking on the pure AST - we use this for sanity checks only *) + +open Pure +open PureUtils + +(** Utility function, used for type checking *) +let get_adt_field_types (type_decls : type_decl TypeDeclId.Map.t) + (type_id : type_id) (variant_id : VariantId.id option) (tys : ty list) : + ty list = + match type_id with + | Tuple -> + (* Tuple *) + assert (variant_id = None); + tys + | AdtId def_id -> + (* "Regular" ADT *) + let def = TypeDeclId.Map.find def_id type_decls in + type_decl_get_instantiated_fields_types def variant_id tys + | Assumed aty -> ( + (* Assumed type *) + match aty with + | State -> + (* [State] is opaque *) + raise (Failure "Unreachable: `State` values are opaque") + | Result -> + let ty = Collections.List.to_cons_nil tys in + let variant_id = Option.get variant_id in + if variant_id = result_return_id then [ ty ] + else if variant_id = result_fail_id then [] + else + raise (Failure "Unreachable: improper variant id for result type") + | Option -> + let ty = Collections.List.to_cons_nil tys in + let variant_id = Option.get variant_id in + if variant_id = option_some_id then [ ty ] + else if variant_id = option_none_id then [] + else + raise (Failure "Unreachable: improper variant id for result type") + | Vec -> raise (Failure "Unreachable: `Vector` values are opaque")) + +type tc_ctx = { + type_decls : type_decl TypeDeclId.Map.t; (** The type declarations *) + global_decls : A.global_decl A.GlobalDeclId.Map.t; + (** The global declarations *) + env : ty VarId.Map.t; (** Environment from variables to types *) +} + +let check_constant_value (v : constant_value) (ty : ty) : unit = + match (ty, v) with + | Integer int_ty, V.Scalar sv -> assert (int_ty = sv.V.int_ty) + | Bool, Bool _ | Char, Char _ | Str, String _ -> () + | _ -> raise (Failure "Inconsistent type") + +let rec check_typed_pattern (ctx : tc_ctx) (v : typed_pattern) : tc_ctx = + log#ldebug (lazy ("check_typed_pattern: " ^ show_typed_pattern v)); + match v.value with + | PatConcrete cv -> + check_constant_value cv v.ty; + ctx + | PatDummy -> ctx + | PatVar (var, _) -> + assert (var.ty = v.ty); + let env = VarId.Map.add var.id var.ty ctx.env in + { ctx with env } + | PatAdt av -> + (* Compute the field types *) + let type_id, tys = + match v.ty with + | Adt (type_id, tys) -> (type_id, tys) + | _ -> raise (Failure "Inconsistently typed value") + in + let field_tys = + get_adt_field_types ctx.type_decls type_id av.variant_id tys + in + let check_value (ctx : tc_ctx) (ty : ty) (v : typed_pattern) : tc_ctx = + if ty <> v.ty then ( + log#serror + ("check_typed_pattern: not the same types:" ^ "\n- ty: " + ^ show_ty ty ^ "\n- v.ty: " ^ show_ty v.ty); + raise (Failure "Inconsistent types")); + check_typed_pattern ctx v + in + (* Check the field types: check that the field patterns have the expected + * types, and check that the field patterns themselves are well-typed *) + List.fold_left + (fun ctx (ty, v) -> check_value ctx ty v) + ctx + (List.combine field_tys av.field_values) + +let rec check_texpression (ctx : tc_ctx) (e : texpression) : unit = + match e.e with + | Var var_id -> ( + (* Lookup the variable - note that the variable may not be there, + * if we type-check a subexpression (i.e.: if the variable is introduced + * "outside" of the expression) - TODO: this won't happen once + * we use a locally nameless representation *) + match VarId.Map.find_opt var_id ctx.env with + | None -> () + | Some ty -> assert (ty = e.ty)) + | Const cv -> check_constant_value cv e.ty + | App (app, arg) -> + let input_ty, output_ty = destruct_arrow app.ty in + assert (input_ty = arg.ty); + assert (output_ty = e.ty); + check_texpression ctx app; + check_texpression ctx arg + | Abs (pat, body) -> + let pat_ty, body_ty = destruct_arrow e.ty in + assert (pat.ty = pat_ty); + assert (body.ty = body_ty); + (* Check the pattern and register the introduced variables at the same time *) + let ctx = check_typed_pattern ctx pat in + check_texpression ctx body + | Qualif qualif -> ( + match qualif.id with + | Func _ -> () (* TODO *) + | Global _ -> () (* TODO *) + | Proj { adt_id = proj_adt_id; field_id } -> + (* Note we can only project fields of structures (not enumerations) *) + (* Deconstruct the projector type *) + let adt_ty, field_ty = destruct_arrow e.ty in + let adt_id, adt_type_args = + match adt_ty with + | Adt (type_id, tys) -> (type_id, tys) + | _ -> raise (Failure "Unreachable") + in + (* Check the ADT type *) + assert (adt_id = proj_adt_id); + assert (adt_type_args = qualif.type_args); + (* Retrieve and check the expected field type *) + let variant_id = None in + let expected_field_tys = + get_adt_field_types ctx.type_decls proj_adt_id variant_id + qualif.type_args + in + let expected_field_ty = FieldId.nth expected_field_tys field_id in + assert (expected_field_ty = field_ty) + | AdtCons id -> ( + let expected_field_tys = + get_adt_field_types ctx.type_decls id.adt_id id.variant_id + qualif.type_args + in + let field_tys, adt_ty = destruct_arrows e.ty in + assert (expected_field_tys = field_tys); + match adt_ty with + | Adt (type_id, tys) -> + assert (type_id = id.adt_id); + assert (tys = qualif.type_args) + | _ -> raise (Failure "Unreachable"))) + | Let (monadic, pat, re, e_next) -> + let expected_pat_ty = if monadic then destruct_result re.ty else re.ty in + assert (pat.ty = expected_pat_ty); + assert (e.ty = e_next.ty); + (* Check the right-expression *) + check_texpression ctx re; + (* Check the pattern and register the introduced variables at the same time *) + let ctx = check_typed_pattern ctx pat in + (* Check the next expression *) + check_texpression ctx e_next + | Switch (scrut, switch_body) -> ( + check_texpression ctx scrut; + match switch_body with + | If (e_then, e_else) -> + assert (scrut.ty = Bool); + assert (e_then.ty = e.ty); + assert (e_else.ty = e.ty); + check_texpression ctx e_then; + check_texpression ctx e_else + | Match branches -> + let check_branch (br : match_branch) : unit = + assert (br.pat.ty = scrut.ty); + let ctx = check_typed_pattern ctx br.pat in + check_texpression ctx br.branch + in + List.iter check_branch branches) + | Meta (_, e_next) -> + assert (e_next.ty = e.ty); + check_texpression ctx e_next diff --git a/compiler/PureUtils.ml b/compiler/PureUtils.ml new file mode 100644 index 00000000..39f3d76a --- /dev/null +++ b/compiler/PureUtils.ml @@ -0,0 +1,450 @@ +open Pure + +(** Default logger *) +let log = Logging.pure_utils_log + +(** We use this type as a key for lookups *) +type regular_fun_id = A.fun_id * T.RegionGroupId.id option +[@@deriving show, ord] + +module RegularFunIdOrderedType = struct + type t = regular_fun_id + + let compare = compare_regular_fun_id + let to_string = show_regular_fun_id + let pp_t = pp_regular_fun_id + let show_t = show_regular_fun_id +end + +module RegularFunIdMap = Collections.MakeMap (RegularFunIdOrderedType) + +module FunIdOrderedType = struct + type t = fun_id + + let compare = compare_fun_id + let to_string = show_fun_id + let pp_t = pp_fun_id + let show_t = show_fun_id +end + +module FunIdMap = Collections.MakeMap (FunIdOrderedType) +module FunIdSet = Collections.MakeSet (FunIdOrderedType) + +let dest_arrow_ty (ty : ty) : ty * ty = + match ty with + | Arrow (arg_ty, ret_ty) -> (arg_ty, ret_ty) + | _ -> raise (Failure "Unreachable") + +let compute_constant_value_ty (cv : constant_value) : ty = + match cv with + | V.Scalar sv -> Integer sv.V.int_ty + | Bool _ -> Bool + | Char _ -> Char + | String _ -> Str + +let mk_typed_pattern_from_constant_value (cv : constant_value) : typed_pattern = + let ty = compute_constant_value_ty cv in + { value = PatConcrete cv; ty } + +let mk_let (monadic : bool) (lv : typed_pattern) (re : texpression) + (next_e : texpression) : texpression = + let e = Let (monadic, lv, re, next_e) in + let ty = next_e.ty in + { e; ty } + +(** Type substitution *) +let ty_substitute (tsubst : TypeVarId.id -> ty) (ty : ty) : ty = + let obj = + object + inherit [_] map_ty + method! visit_TypeVar _ var_id = tsubst var_id + end + in + obj#visit_ty () ty + +let make_type_subst (vars : type_var list) (tys : ty list) : TypeVarId.id -> ty + = + let ls = List.combine vars tys in + let mp = + List.fold_left + (fun mp (k, v) -> TypeVarId.Map.add (k : type_var).index v mp) + TypeVarId.Map.empty ls + in + fun id -> TypeVarId.Map.find id mp + +(** Retrieve the list of fields for the given variant of a {!Pure.type_decl}. + + Raises [Invalid_argument] if the arguments are incorrect. + *) +let type_decl_get_fields (def : type_decl) + (opt_variant_id : VariantId.id option) : field list = + match (def.kind, opt_variant_id) with + | Enum variants, Some variant_id -> (VariantId.nth variants variant_id).fields + | Struct fields, None -> fields + | _ -> + let opt_variant_id = + match opt_variant_id with None -> "None" | Some _ -> "Some" + in + raise + (Invalid_argument + ("The variant id should be [Some] if and only if the definition is \ + an enumeration:\n\ + - def: " ^ show_type_decl def ^ "\n- opt_variant_id: " + ^ opt_variant_id)) + +(** Instantiate the type variables for the chosen variant in an ADT definition, + and return the list of the types of its fields *) +let type_decl_get_instantiated_fields_types (def : type_decl) + (opt_variant_id : VariantId.id option) (types : ty list) : ty list = + let ty_subst = make_type_subst def.type_params types in + let fields = type_decl_get_fields def opt_variant_id in + List.map (fun f -> ty_substitute ty_subst f.field_ty) fields + +let fun_sig_substitute (tsubst : TypeVarId.id -> ty) (sg : fun_sig) : + inst_fun_sig = + let subst = ty_substitute tsubst in + let inputs = List.map subst sg.inputs in + let output = subst sg.output in + let doutputs = List.map subst sg.doutputs in + let info = sg.info in + { inputs; output; doutputs; info } + +(** Return true if a list of functions are *not* mutually recursive, false otherwise. + This function is meant to be applied on a set of (forward, backwards) functions + generated for one recursive function. + The way we do the test is very simple: + - we explore the functions one by one, in the order + - if all functions only call functions we already explored, they are not + mutually recursive + *) +let functions_not_mutually_recursive (funs : fun_decl list) : bool = + (* Compute the set of function identifiers in the group *) + let ids = + FunIdSet.of_list + (List.map + (fun (f : fun_decl) -> Regular (A.Regular f.def_id, f.back_id)) + funs) + in + let ids = ref ids in + (* Explore every body *) + let body_only_calls_itself (fdef : fun_decl) : bool = + (* Remove the current id from the id set *) + ids := FunIdSet.remove (Regular (A.Regular fdef.def_id, fdef.back_id)) !ids; + + (* Check if we call functions from the updated id set *) + let obj = + object + inherit [_] iter_expression as super + + method! visit_qualif env qualif = + match qualif.id with + | Func fun_id -> + if FunIdSet.mem fun_id !ids then raise Utils.Found + else super#visit_qualif env qualif + | _ -> super#visit_qualif env qualif + end + in + + try + match fdef.body with + | None -> true + | Some body -> + obj#visit_texpression () body.body; + true + with Utils.Found -> false + in + List.for_all body_only_calls_itself funs + +(** We use this to check whether we need to add parentheses around expressions. + We only look for outer monadic let-bindings. + This is used when printing the branches of [if ... then ... else ...]. + *) +let rec let_group_requires_parentheses (e : texpression) : bool = + match e.e with + | Var _ | Const _ | App _ | Abs _ | Qualif _ -> false + | Let (monadic, _, _, next_e) -> + if monadic then true else let_group_requires_parentheses next_e + | Switch (_, _) -> false + | Meta (_, next_e) -> let_group_requires_parentheses next_e + +let is_var (e : texpression) : bool = + match e.e with Var _ -> true | _ -> false + +let as_var (e : texpression) : VarId.id = + match e.e with Var v -> v | _ -> raise (Failure "Unreachable") + +let is_global (e : texpression) : bool = + match e.e with Qualif { id = Global _; _ } -> true | _ -> false + +let is_const (e : texpression) : bool = + match e.e with Const _ -> true | _ -> false + +(** Remove the external occurrences of {!Meta} *) +let rec unmeta (e : texpression) : texpression = + match e.e with Meta (_, e) -> unmeta e | _ -> e + +(** Remove *all* the meta information *) +let remove_meta (e : texpression) : texpression = + let obj = + object + inherit [_] map_expression as super + method! visit_Meta env _ e = super#visit_expression env e.e + end + in + obj#visit_texpression () e + +let mk_arrow (ty0 : ty) (ty1 : ty) : ty = Arrow (ty0, ty1) + +(** Construct a type as a list of arrows: ty1 -> ... tyn *) +let mk_arrows (inputs : ty list) (output : ty) = + let rec aux (tys : ty list) : ty = + match tys with [] -> output | ty :: tys' -> Arrow (ty, aux tys') + in + aux inputs + +(** Destruct an [App] expression into an expression and a list of arguments. + + We simply destruct the expression as long as it is of the form [App (f, x)]. + *) +let destruct_apps (e : texpression) : texpression * texpression list = + let rec aux (args : texpression list) (e : texpression) : + texpression * texpression list = + match e.e with App (f, x) -> aux (x :: args) f | _ -> (e, args) + in + aux [] e + +(** Make an [App (app, arg)] expression *) +let mk_app (app : texpression) (arg : texpression) : texpression = + match app.ty with + | Arrow (ty0, ty1) -> + (* Sanity check *) + assert (ty0 = arg.ty); + let e = App (app, arg) in + let ty = ty1 in + { e; ty } + | _ -> raise (Failure "Expected an arrow type") + +(** The reverse of {!destruct_apps} *) +let mk_apps (app : texpression) (args : texpression list) : texpression = + List.fold_left (fun app arg -> mk_app app arg) app args + +(** Destruct an expression into a qualif identifier and a list of arguments, + * if possible *) +let opt_destruct_qualif_app (e : texpression) : + (qualif * texpression list) option = + let app, args = destruct_apps e in + match app.e with Qualif qualif -> Some (qualif, args) | _ -> None + +(** Destruct an expression into a qualif identifier and a list of arguments *) +let destruct_qualif_app (e : texpression) : qualif * texpression list = + Option.get (opt_destruct_qualif_app e) + +(** Destruct an expression into a function call, if possible *) +let opt_destruct_function_call (e : texpression) : + (fun_id * ty list * texpression list) option = + match opt_destruct_qualif_app e with + | None -> None + | Some (qualif, args) -> ( + match qualif.id with + | Func fun_id -> Some (fun_id, qualif.type_args, args) + | _ -> None) + +let opt_destruct_result (ty : ty) : ty option = + match ty with + | Adt (Assumed Result, tys) -> Some (Collections.List.to_cons_nil tys) + | _ -> None + +let destruct_result (ty : ty) : ty = Option.get (opt_destruct_result ty) + +let opt_destruct_tuple (ty : ty) : ty list option = + match ty with Adt (Tuple, tys) -> Some tys | _ -> None + +let mk_abs (x : typed_pattern) (e : texpression) : texpression = + let ty = Arrow (x.ty, e.ty) in + let e = Abs (x, e) in + { e; ty } + +let rec destruct_abs_list (e : texpression) : typed_pattern list * texpression = + match e.e with + | Abs (x, e') -> + let xl, e'' = destruct_abs_list e' in + (x :: xl, e'') + | _ -> ([], e) + +let destruct_arrow (ty : ty) : ty * ty = + match ty with + | Arrow (ty0, ty1) -> (ty0, ty1) + | _ -> raise (Failure "Not an arrow type") + +let rec destruct_arrows (ty : ty) : ty list * ty = + match ty with + | Arrow (ty0, ty1) -> + let tys, out_ty = destruct_arrows ty1 in + (ty0 :: tys, out_ty) + | _ -> ([], ty) + +let get_switch_body_ty (sb : switch_body) : ty = + match sb with + | If (e_then, _) -> e_then.ty + | Match branches -> + (* There should be at least one branch *) + (List.hd branches).branch.ty + +let map_switch_body_branches (f : texpression -> texpression) (sb : switch_body) + : switch_body = + match sb with + | If (e_then, e_else) -> If (f e_then, f e_else) + | Match branches -> + Match + (List.map + (fun (b : match_branch) -> { b with branch = f b.branch }) + branches) + +let iter_switch_body_branches (f : texpression -> unit) (sb : switch_body) : + unit = + match sb with + | If (e_then, e_else) -> + f e_then; + f e_else + | Match branches -> List.iter (fun (b : match_branch) -> f b.branch) branches + +let mk_switch (scrut : texpression) (sb : switch_body) : texpression = + (* Sanity check: the scrutinee has the proper type *) + (match sb with + | If (_, _) -> assert (scrut.ty = Bool) + | Match branches -> + List.iter + (fun (b : match_branch) -> assert (b.pat.ty = scrut.ty)) + branches); + (* Sanity check: all the branches have the same type *) + let ty = get_switch_body_ty sb in + iter_switch_body_branches (fun e -> assert (e.ty = ty)) sb; + (* Put together *) + let e = Switch (scrut, sb) in + { e; ty } + +(** Make a "simplified" tuple type from a list of types: + - if there is exactly one type, just return it + - if there is > one type: wrap them in a tuple + *) +let mk_simpl_tuple_ty (tys : ty list) : ty = + match tys with [ ty ] -> ty | _ -> Adt (Tuple, tys) + +let mk_unit_ty : ty = Adt (Tuple, []) + +let mk_unit_rvalue : texpression = + let id = AdtCons { adt_id = Tuple; variant_id = None } in + let qualif = { id; type_args = [] } in + let e = Qualif qualif in + let ty = mk_unit_ty in + { e; ty } + +let mk_texpression_from_var (v : var) : texpression = + let e = Var v.id in + let ty = v.ty in + { e; ty } + +let mk_typed_pattern_from_var (v : var) (mp : mplace option) : typed_pattern = + let value = PatVar (v, mp) in + let ty = v.ty in + { value; ty } + +let mk_meta (m : meta) (e : texpression) : texpression = + let ty = e.ty in + let e = Meta (m, e) in + { e; ty } + +let mk_mplace_texpression (mp : mplace) (e : texpression) : texpression = + mk_meta (MPlace mp) e + +let mk_opt_mplace_texpression (mp : mplace option) (e : texpression) : + texpression = + match mp with None -> e | Some mp -> mk_mplace_texpression mp e + +(** Make a "simplified" tuple value from a list of values: + - if there is exactly one value, just return it + - if there is > one value: wrap them in a tuple + *) +let mk_simpl_tuple_pattern (vl : typed_pattern list) : typed_pattern = + match vl with + | [ v ] -> v + | _ -> + let tys = List.map (fun (v : typed_pattern) -> v.ty) vl in + let ty = Adt (Tuple, tys) in + let value = PatAdt { variant_id = None; field_values = vl } in + { value; ty } + +(** Similar to {!mk_simpl_tuple_pattern} *) +let mk_simpl_tuple_texpression (vl : texpression list) : texpression = + match vl with + | [ v ] -> v + | _ -> + (* Compute the types of the fields, and the type of the tuple constructor *) + let tys = List.map (fun (v : texpression) -> v.ty) vl in + let ty = Adt (Tuple, tys) in + let ty = mk_arrows tys ty in + (* Construct the tuple constructor qualifier *) + let id = AdtCons { adt_id = Tuple; variant_id = None } in + let qualif = { id; type_args = tys } in + (* Put everything together *) + let cons = { e = Qualif qualif; ty } in + mk_apps cons vl + +let mk_adt_pattern (adt_ty : ty) (variant_id : VariantId.id) + (vl : typed_pattern list) : typed_pattern = + let value = PatAdt { variant_id = Some variant_id; field_values = vl } in + { value; ty = adt_ty } + +let ty_as_integer (t : ty) : T.integer_type = + match t with Integer int_ty -> int_ty | _ -> raise (Failure "Unreachable") + +(* TODO: move *) +let type_decl_is_enum (def : T.type_decl) : bool = + match def.kind with T.Struct _ -> false | Enum _ -> true | Opaque -> false + +let mk_state_ty : ty = Adt (Assumed State, []) +let mk_result_ty (ty : ty) : ty = Adt (Assumed Result, [ ty ]) + +let unwrap_result_ty (ty : ty) : ty = + match ty with + | Adt (Assumed Result, [ ty ]) -> ty + | _ -> failwith "not a result type" + +let mk_result_fail_texpression (ty : ty) : texpression = + let type_args = [ ty ] in + let ty = Adt (Assumed Result, type_args) in + let id = + AdtCons { adt_id = Assumed Result; variant_id = Some result_fail_id } + in + let qualif = { id; type_args } in + let cons_e = Qualif qualif in + let cons_ty = ty in + let cons = { e = cons_e; ty = cons_ty } in + cons + +let mk_result_return_texpression (v : texpression) : texpression = + let type_args = [ v.ty ] in + let ty = Adt (Assumed Result, type_args) in + let id = + AdtCons { adt_id = Assumed Result; variant_id = Some result_return_id } + in + let qualif = { id; type_args } in + let cons_e = Qualif qualif in + let cons_ty = mk_arrow v.ty ty in + let cons = { e = cons_e; ty = cons_ty } in + mk_app cons v + +let mk_result_fail_pattern (ty : ty) : typed_pattern = + let ty = Adt (Assumed Result, [ ty ]) in + let value = PatAdt { variant_id = Some result_fail_id; field_values = [] } in + { value; ty } + +let mk_result_return_pattern (v : typed_pattern) : typed_pattern = + let ty = Adt (Assumed Result, [ v.ty ]) in + let value = + PatAdt { variant_id = Some result_return_id; field_values = [ v ] } + in + { value; ty } + +let opt_unmeta_mplace (e : texpression) : mplace option * texpression = + match e.e with Meta (MPlace mp, e) -> (Some mp, e) | _ -> (None, e) diff --git a/compiler/Scalars.ml b/compiler/Scalars.ml new file mode 100644 index 00000000..03ca506c --- /dev/null +++ b/compiler/Scalars.ml @@ -0,0 +1,59 @@ +open Types +open Values + +(** The minimum/maximum values an integer type can have depending on its type *) + +let i8_min = Z.of_string "-128" +let i8_max = Z.of_string "127" +let i16_min = Z.of_string "-32768" +let i16_max = Z.of_string "32767" +let i32_min = Z.of_string "-2147483648" +let i32_max = Z.of_string "2147483647" +let i64_min = Z.of_string "-9223372036854775808" +let i64_max = Z.of_string "9223372036854775807" +let i128_min = Z.of_string "-170141183460469231731687303715884105728" +let i128_max = Z.of_string "170141183460469231731687303715884105727" +let u8_min = Z.of_string "0" +let u8_max = Z.of_string "255" +let u16_min = Z.of_string "0" +let u16_max = Z.of_string "65535" +let u32_min = Z.of_string "0" +let u32_max = Z.of_string "4294967295" +let u64_min = Z.of_string "0" +let u64_max = Z.of_string "18446744073709551615" +let u128_min = Z.of_string "0" +let u128_max = Z.of_string "340282366920938463463374607431768211455" + +(** Being a bit conservative about isize/usize: depending on the system, + the values are encoded as 32-bit values or 64-bit values - we may + want to take that into account in the future *) + +let isize_min = i32_min +let isize_max = i32_max +let usize_min = u32_min +let usize_max = u32_max + +(** Check that an integer value is in range *) +let check_int_in_range (int_ty : integer_type) (i : big_int) : bool = + match int_ty with + | Isize -> Z.leq isize_min i && Z.leq i isize_max + | I8 -> Z.leq i8_min i && Z.leq i i8_max + | I16 -> Z.leq i16_min i && Z.leq i i16_max + | I32 -> Z.leq i32_min i && Z.leq i i32_max + | I64 -> Z.leq i64_min i && Z.leq i i64_max + | I128 -> Z.leq i128_min i && Z.leq i i128_max + | Usize -> Z.leq usize_min i && Z.leq i usize_max + | U8 -> Z.leq u8_min i && Z.leq i u8_max + | U16 -> Z.leq u16_min i && Z.leq i u16_max + | U32 -> Z.leq u32_min i && Z.leq i u32_max + | U64 -> Z.leq u64_min i && Z.leq i u64_max + | U128 -> Z.leq u128_min i && Z.leq i u128_max + +(** Check that a scalar value is correct (the integer value it contains is in range) *) +let check_scalar_value_in_range (v : scalar_value) : bool = + check_int_in_range v.int_ty v.value + +(** Make a scalar value, while checking the value is in range *) +let mk_scalar (int_ty : integer_type) (i : big_int) : + (scalar_value, unit) result = + if check_int_in_range int_ty i then Ok { value = i; int_ty } else Error () diff --git a/compiler/StringUtils.ml b/compiler/StringUtils.ml new file mode 100644 index 00000000..0fd46136 --- /dev/null +++ b/compiler/StringUtils.ml @@ -0,0 +1,106 @@ +(** Utilities to work on strings, character per character. + + They operate on ASCII strings, and are used by the project to convert + Rust names: Rust names are not fancy, so it shouldn't be a problem. + + Rk.: the poor support of OCaml for char manipulation is really annoying... + *) + +let code_0 = 48 +let code_9 = 57 +let code_A = 65 +let code_Z = 90 +let code_a = 97 +let code_z = 122 + +let is_lowercase_ascii (c : char) : bool = + let c = Char.code c in + code_a <= c && c <= code_z + +let is_uppercase_ascii (c : char) : bool = + let c = Char.code c in + code_A <= c && c <= code_Z + +let is_letter_ascii (c : char) : bool = + is_lowercase_ascii c || is_uppercase_ascii c + +let is_digit_ascii (c : char) : bool = + let c = Char.code c in + code_0 <= c && c <= code_9 + +let lowercase_ascii = Char.lowercase_ascii +let uppercase_ascii = Char.uppercase_ascii + +(** Using buffers as per: + {{: https://stackoverflow.com/questions/29957418/how-to-convert-char-list-to-string-in-ocaml} stackoverflow} + *) +let string_of_chars (chars : char list) : string = + let buf = Buffer.create (List.length chars) in + List.iter (Buffer.add_char buf) chars; + Buffer.contents buf + +let string_to_chars (s : string) : char list = + let length = String.length s in + let rec apply i = + if i = length then [] else String.get s i :: apply (i + 1) + in + apply 0 + +(** This operates on ASCII *) +let to_camel_case (s : string) : string = + (* Note that we rebuild the string in reverse order *) + let apply ((prev_is_under, acc) : bool * char list) (c : char) : + bool * char list = + if c = '_' then (true, acc) + else + let c = if prev_is_under then uppercase_ascii c else c in + (false, c :: acc) + in + let _, chars = List.fold_left apply (true, []) (string_to_chars s) in + string_of_chars (List.rev chars) + +(** This operates on ASCII *) +let to_snake_case (s : string) : string = + (* Note that we rebuild the string in reverse order *) + let apply ((prev_is_low, prev_is_digit, acc) : bool * bool * char list) + (c : char) : bool * bool * char list = + let acc = + if c = '_' then acc + else if prev_is_digit then if is_letter_ascii c then '_' :: acc else acc + else if prev_is_low then + if (is_lowercase_ascii c || is_digit_ascii c) && c <> '_' then acc + else '_' :: acc + else acc + in + let prev_is_low = is_lowercase_ascii c in + let prev_is_digit = is_digit_ascii c in + let c = lowercase_ascii c in + (prev_is_low, prev_is_digit, c :: acc) + in + let _, _, chars = + List.fold_left apply (false, false, []) (string_to_chars s) + in + string_of_chars (List.rev chars) + +(** Applies a map operation. + + This is very inefficient, but shouldn't be used much. + *) +let map (f : char -> string) (s : string) : string = + let sl = List.map f (string_to_chars s) in + let sl = List.map string_to_chars sl in + string_of_chars (List.concat sl) + +let capitalize_first_letter (s : string) : string = + let s = string_to_chars s in + let s = match s with [] -> s | c :: s' -> uppercase_ascii c :: s' in + string_of_chars s + +(** Unit tests *) +let _ = + assert (to_camel_case "hello_world" = "HelloWorld"); + assert (to_snake_case "HelloWorld36Hello" = "hello_world36_hello"); + assert (to_snake_case "HELLO" = "hello"); + assert (to_snake_case "T1" = "t1"); + assert (to_camel_case "list" = "List"); + assert (to_snake_case "is_cons" = "is_cons") diff --git a/compiler/Substitute.ml b/compiler/Substitute.ml new file mode 100644 index 00000000..5e5858de --- /dev/null +++ b/compiler/Substitute.ml @@ -0,0 +1,357 @@ +(** This file implements various substitution utilities to instantiate types, + function bodies, etc. + *) + +module T = Types +module TU = TypesUtils +module V = Values +module E = Expressions +module A = LlbcAst +module C = Contexts + +(** Substitute types variables and regions in a type. + + TODO: we can reimplement that with visitors. + *) +let rec ty_substitute (rsubst : 'r1 -> 'r2) + (tsubst : T.TypeVarId.id -> 'r2 T.ty) (ty : 'r1 T.ty) : 'r2 T.ty = + let open T in + let subst = ty_substitute rsubst tsubst in + (* helper *) + match ty with + | Adt (def_id, regions, tys) -> + Adt (def_id, List.map rsubst regions, List.map subst tys) + | Array aty -> Array (subst aty) + | Slice sty -> Slice (subst sty) + | Ref (r, ref_ty, ref_kind) -> Ref (rsubst r, subst ref_ty, ref_kind) + (* Below variants: we technically return the same value, but because + one has type ['r1 ty] and the other has type ['r2 ty], we need to + deconstruct then reconstruct *) + | Bool -> Bool + | Char -> Char + | Never -> Never + | Integer int_ty -> Integer int_ty + | Str -> Str + | TypeVar vid -> tsubst vid + +(** Convert an {!T.rty} to an {!T.ety} by erasing the region variables *) +let erase_regions (ty : T.rty) : T.ety = + ty_substitute (fun _ -> T.Erased) (fun vid -> T.TypeVar vid) ty + +(** Generate fresh regions for region variables. + + Return the list of new regions and appropriate substitutions from the + original region variables to the fresh regions. + + TODO: simplify? we only need the subst [T.RegionVarId.id -> T.RegionId.id] + *) +let fresh_regions_with_substs (region_vars : T.region_var list) : + T.RegionId.id list + * (T.RegionVarId.id -> T.RegionId.id) + * (T.RegionVarId.id T.region -> T.RegionId.id T.region) = + (* Generate fresh regions *) + let fresh_region_ids = List.map (fun _ -> C.fresh_region_id ()) region_vars in + (* Generate the map from region var ids to regions *) + let ls = List.combine region_vars fresh_region_ids in + let rid_map = + List.fold_left + (fun mp (k, v) -> T.RegionVarId.Map.add k.T.index v mp) + T.RegionVarId.Map.empty ls + in + (* Generate the substitution from region var id to region *) + let rid_subst id = T.RegionVarId.Map.find id rid_map in + (* Generate the substitution from region to region *) + let rsubst r = + match r with T.Static -> T.Static | T.Var id -> T.Var (rid_subst id) + in + (* Return *) + (fresh_region_ids, rid_subst, rsubst) + +(** Erase the regions in a type and substitute the type variables *) +let erase_regions_substitute_types (tsubst : T.TypeVarId.id -> T.ety) + (ty : 'r T.region T.ty) : T.ety = + let rsubst (_ : 'r T.region) : T.erased_region = T.Erased in + ty_substitute rsubst tsubst ty + +(** Create a region substitution from a list of region variable ids and a list of + regions (with which to substitute the region variable ids *) +let make_region_subst (var_ids : T.RegionVarId.id list) + (regions : 'r T.region list) : T.RegionVarId.id T.region -> 'r T.region = + let ls = List.combine var_ids regions in + let mp = + List.fold_left + (fun mp (k, v) -> T.RegionVarId.Map.add k v mp) + T.RegionVarId.Map.empty ls + in + fun r -> + match r with + | T.Static -> T.Static + | T.Var id -> T.RegionVarId.Map.find id mp + +(** Create a type substitution from a list of type variable ids and a list of + types (with which to substitute the type variable ids) *) +let make_type_subst (var_ids : T.TypeVarId.id list) (tys : 'r T.ty list) : + T.TypeVarId.id -> 'r T.ty = + let ls = List.combine var_ids tys in + let mp = + List.fold_left + (fun mp (k, v) -> T.TypeVarId.Map.add k v mp) + T.TypeVarId.Map.empty ls + in + fun id -> T.TypeVarId.Map.find id mp + +(** Instantiate the type variables in an ADT definition, and return, for + every variant, the list of the types of its fields *) +let type_decl_get_instantiated_variants_fields_rtypes (def : T.type_decl) + (regions : T.RegionId.id T.region list) (types : T.rty list) : + (T.VariantId.id option * T.rty list) list = + let r_subst = + make_region_subst + (List.map (fun x -> x.T.index) def.T.region_params) + regions + in + let ty_subst = + make_type_subst (List.map (fun x -> x.T.index) def.T.type_params) types + in + let (variants_fields : (T.VariantId.id option * T.field list) list) = + match def.T.kind with + | T.Enum variants -> + List.mapi + (fun i v -> (Some (T.VariantId.of_int i), v.T.fields)) + variants + | T.Struct fields -> [ (None, fields) ] + | T.Opaque -> + raise + (Failure + ("Can't retrieve the variants of an opaque type: " + ^ Names.name_to_string def.name)) + in + List.map + (fun (id, fields) -> + ( id, + List.map (fun f -> ty_substitute r_subst ty_subst f.T.field_ty) fields + )) + variants_fields + +(** Instantiate the type variables in an ADT definition, and return the list + of types of the fields for the chosen variant *) +let type_decl_get_instantiated_field_rtypes (def : T.type_decl) + (opt_variant_id : T.VariantId.id option) + (regions : T.RegionId.id T.region list) (types : T.rty list) : T.rty list = + let r_subst = + make_region_subst + (List.map (fun x -> x.T.index) def.T.region_params) + regions + in + let ty_subst = + make_type_subst (List.map (fun x -> x.T.index) def.T.type_params) types + in + let fields = TU.type_decl_get_fields def opt_variant_id in + List.map (fun f -> ty_substitute r_subst ty_subst f.T.field_ty) fields + +(** Return the types of the properly instantiated ADT's variant, provided a + context *) +let ctx_adt_get_instantiated_field_rtypes (ctx : C.eval_ctx) + (def_id : T.TypeDeclId.id) (opt_variant_id : T.VariantId.id option) + (regions : T.RegionId.id T.region list) (types : T.rty list) : T.rty list = + let def = C.ctx_lookup_type_decl ctx def_id in + type_decl_get_instantiated_field_rtypes def opt_variant_id regions types + +(** Return the types of the properly instantiated ADT value (note that + here, ADT is understood in its broad meaning: ADT, assumed value or tuple) *) +let ctx_adt_value_get_instantiated_field_rtypes (ctx : C.eval_ctx) + (adt : V.adt_value) (id : T.type_id) + (region_params : T.RegionId.id T.region list) (type_params : T.rty list) : + T.rty list = + match id with + | T.AdtId id -> + (* Retrieve the types of the fields *) + ctx_adt_get_instantiated_field_rtypes ctx id adt.V.variant_id + region_params type_params + | T.Tuple -> + assert (List.length region_params = 0); + type_params + | T.Assumed aty -> ( + match aty with + | T.Box | T.Vec -> + assert (List.length region_params = 0); + assert (List.length type_params = 1); + type_params + | T.Option -> + assert (List.length region_params = 0); + assert (List.length type_params = 1); + if adt.V.variant_id = Some T.option_some_id then type_params + else if adt.V.variant_id = Some T.option_none_id then [] + else failwith "Unrechable") + +(** Instantiate the type variables in an ADT definition, and return the list + of types of the fields for the chosen variant *) +let type_decl_get_instantiated_field_etypes (def : T.type_decl) + (opt_variant_id : T.VariantId.id option) (types : T.ety list) : T.ety list = + let ty_subst = + make_type_subst (List.map (fun x -> x.T.index) def.T.type_params) types + in + let fields = TU.type_decl_get_fields def opt_variant_id in + List.map + (fun f -> erase_regions_substitute_types ty_subst f.T.field_ty) + fields + +(** Return the types of the properly instantiated ADT's variant, provided a + context *) +let ctx_adt_get_instantiated_field_etypes (ctx : C.eval_ctx) + (def_id : T.TypeDeclId.id) (opt_variant_id : T.VariantId.id option) + (types : T.ety list) : T.ety list = + let def = C.ctx_lookup_type_decl ctx def_id in + type_decl_get_instantiated_field_etypes def opt_variant_id types + +(** Apply a type substitution to a place *) +let place_substitute (_tsubst : T.TypeVarId.id -> T.ety) (p : E.place) : E.place + = + (* There is nothing to do *) + p + +(** Apply a type substitution to an operand *) +let operand_substitute (tsubst : T.TypeVarId.id -> T.ety) (op : E.operand) : + E.operand = + let p_subst = place_substitute tsubst in + match op with + | E.Copy p -> E.Copy (p_subst p) + | E.Move p -> E.Move (p_subst p) + | E.Constant (ety, cv) -> + let rsubst x = x in + E.Constant (ty_substitute rsubst tsubst ety, cv) + +(** Apply a type substitution to an rvalue *) +let rvalue_substitute (tsubst : T.TypeVarId.id -> T.ety) (rv : E.rvalue) : + E.rvalue = + let op_subst = operand_substitute tsubst in + let p_subst = place_substitute tsubst in + match rv with + | E.Use op -> E.Use (op_subst op) + | E.Ref (p, bkind) -> E.Ref (p_subst p, bkind) + | E.UnaryOp (unop, op) -> E.UnaryOp (unop, op_subst op) + | E.BinaryOp (binop, op1, op2) -> + E.BinaryOp (binop, op_subst op1, op_subst op2) + | E.Discriminant p -> E.Discriminant (p_subst p) + | E.Aggregate (kind, ops) -> + let ops = List.map op_subst ops in + let kind = + match kind with + | E.AggregatedTuple -> E.AggregatedTuple + | E.AggregatedOption (variant_id, ty) -> + let rsubst r = r in + E.AggregatedOption (variant_id, ty_substitute rsubst tsubst ty) + | E.AggregatedAdt (def_id, variant_id, regions, tys) -> + let rsubst r = r in + E.AggregatedAdt + ( def_id, + variant_id, + regions, + List.map (ty_substitute rsubst tsubst) tys ) + in + E.Aggregate (kind, ops) + +(** Apply a type substitution to an assertion *) +let assertion_substitute (tsubst : T.TypeVarId.id -> T.ety) (a : A.assertion) : + A.assertion = + { A.cond = operand_substitute tsubst a.A.cond; A.expected = a.A.expected } + +(** Apply a type substitution to a call *) +let call_substitute (tsubst : T.TypeVarId.id -> T.ety) (call : A.call) : A.call + = + let rsubst x = x in + let type_args = List.map (ty_substitute rsubst tsubst) call.A.type_args in + let args = List.map (operand_substitute tsubst) call.A.args in + let dest = place_substitute tsubst call.A.dest in + (* Putting all the paramters on purpose: we want to get a compiler error if + something moves - we may add a field on which we need to apply a substitution *) + { + func = call.A.func; + region_args = call.A.region_args; + A.type_args; + args; + dest; + } + +(** Apply a type substitution to a statement *) +let rec statement_substitute (tsubst : T.TypeVarId.id -> T.ety) + (st : A.statement) : A.statement = + { st with A.content = raw_statement_substitute tsubst st.content } + +and raw_statement_substitute (tsubst : T.TypeVarId.id -> T.ety) + (st : A.raw_statement) : A.raw_statement = + match st with + | A.Assign (p, rvalue) -> + let p = place_substitute tsubst p in + let rvalue = rvalue_substitute tsubst rvalue in + A.Assign (p, rvalue) + | A.AssignGlobal g -> + (* Globals don't have type parameters *) + A.AssignGlobal g + | A.FakeRead p -> + let p = place_substitute tsubst p in + A.FakeRead p + | A.SetDiscriminant (p, vid) -> + let p = place_substitute tsubst p in + A.SetDiscriminant (p, vid) + | A.Drop p -> + let p = place_substitute tsubst p in + A.Drop p + | A.Assert assertion -> + let assertion = assertion_substitute tsubst assertion in + A.Assert assertion + | A.Call call -> + let call = call_substitute tsubst call in + A.Call call + | A.Panic | A.Return | A.Break _ | A.Continue _ | A.Nop -> st + | A.Sequence (st1, st2) -> + A.Sequence + (statement_substitute tsubst st1, statement_substitute tsubst st2) + | A.Switch (op, tgts) -> + A.Switch + (operand_substitute tsubst op, switch_targets_substitute tsubst tgts) + | A.Loop le -> A.Loop (statement_substitute tsubst le) + +(** Apply a type substitution to switch targets *) +and switch_targets_substitute (tsubst : T.TypeVarId.id -> T.ety) + (tgts : A.switch_targets) : A.switch_targets = + match tgts with + | A.If (st1, st2) -> + A.If (statement_substitute tsubst st1, statement_substitute tsubst st2) + | A.SwitchInt (int_ty, tgts, otherwise) -> + let tgts = + List.map (fun (sv, st) -> (sv, statement_substitute tsubst st)) tgts + in + let otherwise = statement_substitute tsubst otherwise in + A.SwitchInt (int_ty, tgts, otherwise) + +(** Apply a type substitution to a function body. Return the local variables + and the body. *) +let fun_body_substitute_in_body (tsubst : T.TypeVarId.id -> T.ety) + (body : A.fun_body) : A.var list * A.statement = + let rsubst r = r in + let locals = + List.map + (fun v -> { v with A.var_ty = ty_substitute rsubst tsubst v.A.var_ty }) + body.A.locals + in + let body = statement_substitute tsubst body.body in + (locals, body) + +(** Substitute a function signature *) +let substitute_signature (asubst : T.RegionGroupId.id -> V.AbstractionId.id) + (rsubst : T.RegionVarId.id -> T.RegionId.id) + (tsubst : T.TypeVarId.id -> T.rty) (sg : A.fun_sig) : A.inst_fun_sig = + let rsubst' (r : T.RegionVarId.id T.region) : T.RegionId.id T.region = + match r with T.Static -> T.Static | T.Var rid -> T.Var (rsubst rid) + in + let inputs = List.map (ty_substitute rsubst' tsubst) sg.A.inputs in + let output = ty_substitute rsubst' tsubst sg.A.output in + let subst_region_group (rg : T.region_var_group) : A.abs_region_group = + let id = asubst rg.id in + let regions = List.map rsubst rg.regions in + let parents = List.map asubst rg.parents in + { id; regions; parents } + in + let regions_hierarchy = List.map subst_region_group sg.A.regions_hierarchy in + { A.regions_hierarchy; inputs; output } diff --git a/compiler/SymbolicAst.ml b/compiler/SymbolicAst.ml new file mode 100644 index 00000000..604a7948 --- /dev/null +++ b/compiler/SymbolicAst.ml @@ -0,0 +1,98 @@ +(** The "symbolic" AST is the AST directly generated by the symbolic execution. + It is very rough and meant to be extremely straightforward to build during + the symbolic execution: we later apply transformations to generate the + pure AST that we export. *) + +module T = Types +module V = Values +module E = Expressions +module A = LlbcAst + +(** "Meta"-place: a place stored as meta-data. + + Whenever we need to introduce new symbolic variables, for instance because + of symbolic expansions, we try to store a "place", which gives information + about the origin of the values (this place information comes from assignment + information, etc.). + We later use this place information to generate meaningful name, to prettify + the generated code. + *) +type mplace = { + bv : Contexts.binder; + (** It is important that we store the binder, and not just the variable id, + because the most important information in a place is the name of the + variable! + *) + projection : E.projection; + (** We store the projection because we can, but it is actually not that useful *) +} + +type call_id = + | Fun of A.fun_id * V.FunCallId.id + (** A "regular" function (i.e., a function which is not a primitive operation) *) + | Unop of E.unop + | Binop of E.binop +[@@deriving show, ord] + +type call = { + call_id : call_id; + abstractions : V.AbstractionId.id list; + type_params : T.ety list; + args : V.typed_value list; + args_places : mplace option list; (** Meta information *) + dest : V.symbolic_value; + dest_place : mplace option; (** Meta information *) +} + +(** Meta information, not necessary for synthesis but useful to guide it to + generate a pretty output. + *) + +type meta = + | Assignment of mplace * V.typed_value * mplace option + (** We generated an assignment (destination, assigned value, src) *) + +(** **Rk.:** here, {!expression} is not at all equivalent to the expressions + used in LLBC: they are a first step towards lambda-calculus expressions. + *) +type expression = + | Return of V.typed_value option + (** There are two cases: + - the AST is for a forward function: the typed value should contain + the value which was in the return variable + - the AST is for a backward function: the typed value should be [None] + *) + | Panic + | FunCall of call * expression + | EndAbstraction of V.abs * expression + | EvalGlobal of A.GlobalDeclId.id * V.symbolic_value * expression + (** Evaluate a global to a fresh symbolic value *) + | Expansion of mplace option * V.symbolic_value * expansion + (** Expansion of a symbolic value. + + The place is "meta": it gives the path to the symbolic value (if available) + which got expanded (this path is available when the symbolic expansion + comes from a path evaluation, during an assignment for instance). + We use it to compute meaningful names for the variables we introduce, + to prettify the generated code. + *) + | Meta of meta * expression (** Meta information *) + +and expansion = + | ExpandNoBranch of V.symbolic_expansion * expression + (** A symbolic expansion which doesn't generate a branching. + Includes: + - concrete expansion + - borrow expansion + *Doesn't* include: + - expansion of ADTs with one variant + *) + | ExpandAdt of + (T.VariantId.id option * V.symbolic_value list * expression) list + (** ADT expansion *) + | ExpandBool of expression * expression + (** A boolean expansion (i.e, an [if ... then ... else ...]) *) + | ExpandInt of + T.integer_type * (V.scalar_value * expression) list * expression + (** An integer expansion (i.e, a switch over an integer). The last + expression is for the "otherwise" branch. *) diff --git a/compiler/SymbolicToPure.ml b/compiler/SymbolicToPure.ml new file mode 100644 index 00000000..de4fb4c1 --- /dev/null +++ b/compiler/SymbolicToPure.ml @@ -0,0 +1,1824 @@ +open Errors +open LlbcAstUtils +open Pure +open PureUtils +module Id = Identifiers +module S = SymbolicAst +module TA = TypesAnalysis +module L = Logging +module PP = PrintPure +module FA = FunsAnalysis + +(** The local logger *) +let log = L.symbolic_to_pure_log + +type config = { + filter_useless_back_calls : bool; + (** If [true], filter the useless calls to backward functions. + + The useless calls are calls to backward functions which have no outputs. + This case happens if the original Rust function only takes *shared* borrows + as inputs, and is thus pretty common. + + We are allowed to do this only because in this specific case, + the backward function fails *exactly* when the forward function fails + (they actually do exactly the same thing, the only difference being + that the forward function can potentially return a value), and upon + reaching the place where we should introduce a call to the backward + function, we know we have introduced a call to the forward function. + + Also note that in general, backward functions "do more things" than + forward functions, and have more opportunities to fail (even though + in the generated code, backward functions should fail exactly when + the forward functions fail). + + We might want to move this optimization to the micro-passes subsequent + to the translation from symbolic to pure, but it is really super easy + to do it when going from symbolic to pure. + Note that we later filter the useless *forward* calls in the micro-passes, + where it is more natural to do. + *) +} + +type type_context = { + llbc_type_decls : T.type_decl TypeDeclId.Map.t; + type_decls : type_decl TypeDeclId.Map.t; + (** We use this for type-checking (for sanity checks) when translating + values and functions. + This map is empty when we translate the types, then contains all + the translated types when we translate the functions. + *) + types_infos : TA.type_infos; (* TODO: rename to type_infos *) +} + +type fun_sig_named_outputs = { + sg : fun_sig; (** A function signature *) + output_names : string option list; + (** In case the signature is for a backward function, we may provides names + for the outputs. The reason is that the outputs of backward functions + come from (in case there are no nested borrows) borrows present in the + inputs of the original rust function. In this situation, we can use the + names of those inputs to name the outputs. Those names are very useful + to generate beautiful codes (we may need to introduce temporary variables + in the bodies of the backward functions to store the returned values, in + which case we use those names). + *) +} + +type fun_context = { + llbc_fun_decls : A.fun_decl A.FunDeclId.Map.t; + fun_sigs : fun_sig_named_outputs RegularFunIdMap.t; (** *) + fun_infos : FA.fun_info A.FunDeclId.Map.t; +} + +type global_context = { llbc_global_decls : A.global_decl A.GlobalDeclId.Map.t } + +(** Whenever we translate a function call or an ended abstraction, we + store the related information (this is useful when translating ended + children abstractions). + *) +type call_info = { + forward : S.call; + forward_inputs : texpression list; + (** Remember the list of inputs given to the forward function. + + Those inputs include the state input, if pertinent (in which case + it is the last input). + *) + backwards : (V.abs * texpression list) T.RegionGroupId.Map.t; + (** A map from region group id (i.e., backward function id) to + pairs (abstraction, additional arguments received by the backward function) + + TODO: remove? it is also in the bs_ctx ("abstractions" field) + *) +} + +(** Body synthesis context *) +type bs_ctx = { + type_context : type_context; + fun_context : fun_context; + global_context : global_context; + fun_decl : A.fun_decl; + bid : T.RegionGroupId.id option; (** TODO: rename *) + sg : fun_sig; + (** The function signature - useful in particular to translate [Panic] *) + sv_to_var : var V.SymbolicValueId.Map.t; + (** Whenever we encounter a new symbolic value (introduced because of + a symbolic expansion or upon ending an abstraction, for instance) + we introduce a new variable (with a let-binding). + *) + var_counter : VarId.generator; + state_var : VarId.id; + (** The current state variable, in case we use a state *) + forward_inputs : var list; + (** The input parameters for the forward function *) + backward_inputs : var list T.RegionGroupId.Map.t; + (** The input parameters for the backward functions *) + backward_outputs : var list T.RegionGroupId.Map.t; + (** The variables that the backward functions will output *) + calls : call_info V.FunCallId.Map.t; + (** The function calls we encountered so far *) + abstractions : (V.abs * texpression list) V.AbstractionId.Map.t; + (** The ended abstractions we encountered so far, with their additional input arguments *) +} + +let type_check_pattern (ctx : bs_ctx) (v : typed_pattern) : unit = + let env = VarId.Map.empty in + let ctx = + { + PureTypeCheck.type_decls = ctx.type_context.type_decls; + global_decls = ctx.global_context.llbc_global_decls; + env; + } + in + let _ = PureTypeCheck.check_typed_pattern ctx v in + () + +let type_check_texpression (ctx : bs_ctx) (e : texpression) : unit = + let env = VarId.Map.empty in + let ctx = + { + PureTypeCheck.type_decls = ctx.type_context.type_decls; + global_decls = ctx.global_context.llbc_global_decls; + env; + } + in + PureTypeCheck.check_texpression ctx e + +(* TODO: move *) +let bs_ctx_to_ast_formatter (ctx : bs_ctx) : Print.LlbcAst.ast_formatter = + Print.LlbcAst.fun_decl_to_ast_formatter ctx.type_context.llbc_type_decls + ctx.fun_context.llbc_fun_decls ctx.global_context.llbc_global_decls + ctx.fun_decl + +let bs_ctx_to_pp_ast_formatter (ctx : bs_ctx) : PrintPure.ast_formatter = + let type_params = ctx.fun_decl.signature.type_params in + let type_decls = ctx.type_context.llbc_type_decls in + let fun_decls = ctx.fun_context.llbc_fun_decls in + let global_decls = ctx.global_context.llbc_global_decls in + PrintPure.mk_ast_formatter type_decls fun_decls global_decls type_params + +let ty_to_string (ctx : bs_ctx) (ty : ty) : string = + let fmt = bs_ctx_to_pp_ast_formatter ctx in + let fmt = PrintPure.ast_to_type_formatter fmt in + PrintPure.ty_to_string fmt ty + +let type_decl_to_string (ctx : bs_ctx) (def : type_decl) : string = + let type_params = def.type_params in + let type_decls = ctx.type_context.llbc_type_decls in + let fmt = PrintPure.mk_type_formatter type_decls type_params in + PrintPure.type_decl_to_string fmt def + +let texpression_to_string (ctx : bs_ctx) (e : texpression) : string = + let fmt = bs_ctx_to_pp_ast_formatter ctx in + PrintPure.texpression_to_string fmt false "" " " e + +let fun_sig_to_string (ctx : bs_ctx) (sg : fun_sig) : string = + let type_params = sg.type_params in + let type_decls = ctx.type_context.llbc_type_decls in + let fun_decls = ctx.fun_context.llbc_fun_decls in + let global_decls = ctx.global_context.llbc_global_decls in + let fmt = + PrintPure.mk_ast_formatter type_decls fun_decls global_decls type_params + in + PrintPure.fun_sig_to_string fmt sg + +let fun_decl_to_string (ctx : bs_ctx) (def : Pure.fun_decl) : string = + let type_params = def.signature.type_params in + let type_decls = ctx.type_context.llbc_type_decls in + let fun_decls = ctx.fun_context.llbc_fun_decls in + let global_decls = ctx.global_context.llbc_global_decls in + let fmt = + PrintPure.mk_ast_formatter type_decls fun_decls global_decls type_params + in + PrintPure.fun_decl_to_string fmt def + +(* TODO: move *) +let abs_to_string (ctx : bs_ctx) (abs : V.abs) : string = + let fmt = bs_ctx_to_ast_formatter ctx in + let fmt = Print.LlbcAst.ast_to_value_formatter fmt in + let indent = "" in + let indent_incr = " " in + Print.Values.abs_to_string fmt indent indent_incr abs + +let get_instantiated_fun_sig (fun_id : A.fun_id) + (back_id : T.RegionGroupId.id option) (tys : ty list) (ctx : bs_ctx) : + inst_fun_sig = + (* Lookup the non-instantiated function signature *) + let sg = + (RegularFunIdMap.find (fun_id, back_id) ctx.fun_context.fun_sigs).sg + in + (* Create the substitution *) + let tsubst = make_type_subst sg.type_params tys in + (* Apply *) + fun_sig_substitute tsubst sg + +let bs_ctx_lookup_llbc_type_decl (id : TypeDeclId.id) (ctx : bs_ctx) : + T.type_decl = + TypeDeclId.Map.find id ctx.type_context.llbc_type_decls + +let bs_ctx_lookup_llbc_fun_decl (id : A.FunDeclId.id) (ctx : bs_ctx) : + A.fun_decl = + A.FunDeclId.Map.find id ctx.fun_context.llbc_fun_decls + +(* TODO: move *) +let bs_ctx_lookup_local_function_sig (def_id : A.FunDeclId.id) + (back_id : T.RegionGroupId.id option) (ctx : bs_ctx) : fun_sig = + let id = (A.Regular def_id, back_id) in + (RegularFunIdMap.find id ctx.fun_context.fun_sigs).sg + +let bs_ctx_register_forward_call (call_id : V.FunCallId.id) (forward : S.call) + (args : texpression list) (ctx : bs_ctx) : bs_ctx = + let calls = ctx.calls in + assert (not (V.FunCallId.Map.mem call_id calls)); + let info = + { forward; forward_inputs = args; backwards = T.RegionGroupId.Map.empty } + in + let calls = V.FunCallId.Map.add call_id info calls in + { ctx with calls } + +(** [back_args]: the *additional* list of inputs received by the backward function *) +let bs_ctx_register_backward_call (abs : V.abs) (back_args : texpression list) + (ctx : bs_ctx) : bs_ctx * fun_id = + (* Insert the abstraction in the call informations *) + let back_id = abs.back_id in + let info = V.FunCallId.Map.find abs.call_id ctx.calls in + assert (not (T.RegionGroupId.Map.mem back_id info.backwards)); + let backwards = + T.RegionGroupId.Map.add back_id (abs, back_args) info.backwards + in + let info = { info with backwards } in + let calls = V.FunCallId.Map.add abs.call_id info ctx.calls in + (* Insert the abstraction in the abstractions map *) + let abstractions = ctx.abstractions in + assert (not (V.AbstractionId.Map.mem abs.abs_id abstractions)); + let abstractions = + V.AbstractionId.Map.add abs.abs_id (abs, back_args) abstractions + in + (* Retrieve the fun_id *) + let fun_id = + match info.forward.call_id with + | S.Fun (fid, _) -> Regular (fid, Some abs.back_id) + | S.Unop _ | S.Binop _ -> raise (Failure "Unreachable") + in + (* Update the context and return *) + ({ ctx with calls; abstractions }, fun_id) + +let rec translate_sty (ty : T.sty) : ty = + let translate = translate_sty in + match ty with + | T.Adt (type_id, regions, tys) -> ( + (* Can't translate types with regions for now *) + assert (regions = []); + let tys = List.map translate tys in + match type_id with + | T.AdtId adt_id -> Adt (AdtId adt_id, tys) + | T.Tuple -> mk_simpl_tuple_ty tys + | T.Assumed aty -> ( + match aty with + | T.Vec -> Adt (Assumed Vec, tys) + | T.Option -> Adt (Assumed Option, tys) + | T.Box -> ( + (* Eliminate the boxes *) + match tys with + | [ ty ] -> ty + | _ -> + failwith + "Box/vec/option type with incorrect number of arguments"))) + | TypeVar vid -> TypeVar vid + | Bool -> Bool + | Char -> Char + | Never -> raise (Failure "Unreachable") + | Integer int_ty -> Integer int_ty + | Str -> Str + | Array ty -> Array (translate ty) + | Slice ty -> Slice (translate ty) + | Ref (_, rty, _) -> translate rty + +let translate_field (f : T.field) : field = + let field_name = f.field_name in + let field_ty = translate_sty f.field_ty in + { field_name; field_ty } + +let translate_fields (fl : T.field list) : field list = + List.map translate_field fl + +let translate_variant (v : T.variant) : variant = + let variant_name = v.variant_name in + let fields = translate_fields v.fields in + { variant_name; fields } + +let translate_variants (vl : T.variant list) : variant list = + List.map translate_variant vl + +(** Translate a type def kind to IM *) +let translate_type_decl_kind (kind : T.type_decl_kind) : type_decl_kind = + match kind with + | T.Struct fields -> Struct (translate_fields fields) + | T.Enum variants -> Enum (translate_variants variants) + | T.Opaque -> Opaque + +(** Translate a type definition from IM + + TODO: this is not symbolic to pure but IM to pure. Still, I don't see the + point of moving this definition for now. + *) +let translate_type_decl (def : T.type_decl) : type_decl = + (* Translate *) + let def_id = def.T.def_id in + let name = def.name in + (* Can't translate types with regions for now *) + assert (def.region_params = []); + let type_params = def.type_params in + let kind = translate_type_decl_kind def.T.kind in + { def_id; name; type_params; kind } + +(** Translate a type, seen as an input/output of a forward function + (preserve all borrows, etc.) +*) + +let rec translate_fwd_ty (types_infos : TA.type_infos) (ty : 'r T.ty) : ty = + let translate = translate_fwd_ty types_infos in + match ty with + | T.Adt (type_id, regions, tys) -> ( + (* Can't translate types with regions for now *) + assert (regions = []); + (* Translate the type parameters *) + let t_tys = List.map translate tys in + (* Eliminate boxes and simplify tuples *) + match type_id with + | AdtId _ | T.Assumed (T.Vec | T.Option) -> + (* No general parametricity for now *) + assert (not (List.exists (TypesUtils.ty_has_borrows types_infos) tys)); + let type_id = + match type_id with + | AdtId adt_id -> AdtId adt_id + | T.Assumed T.Vec -> Assumed Vec + | T.Assumed T.Option -> Assumed Option + | _ -> raise (Failure "Unreachable") + in + Adt (type_id, t_tys) + | Tuple -> + (* Note that if there is exactly one type, [mk_simpl_tuple_ty] is the + identity *) + mk_simpl_tuple_ty t_tys + | T.Assumed T.Box -> ( + (* We eliminate boxes *) + (* No general parametricity for now *) + assert (not (List.exists (TypesUtils.ty_has_borrows types_infos) tys)); + match t_tys with + | [ bty ] -> bty + | _ -> + failwith + "Unreachable: box/vec/option receives exactly one type \ + parameter")) + | TypeVar vid -> TypeVar vid + | Bool -> Bool + | Char -> Char + | Never -> raise (Failure "Unreachable") + | Integer int_ty -> Integer int_ty + | Str -> Str + | Array ty -> + assert (not (TypesUtils.ty_has_borrows types_infos ty)); + Array (translate ty) + | Slice ty -> + assert (not (TypesUtils.ty_has_borrows types_infos ty)); + Slice (translate ty) + | Ref (_, rty, _) -> translate rty + +(** Simply calls [translate_fwd_ty] *) +let ctx_translate_fwd_ty (ctx : bs_ctx) (ty : 'r T.ty) : ty = + let types_infos = ctx.type_context.types_infos in + translate_fwd_ty types_infos ty + +(** Translate a type, when some regions may have ended. + + We return an option, because the translated type may be empty. + + [inside_mut]: are we inside a mutable borrow? + *) +let rec translate_back_ty (types_infos : TA.type_infos) + (keep_region : 'r -> bool) (inside_mut : bool) (ty : 'r T.ty) : ty option = + let translate = translate_back_ty types_infos keep_region inside_mut in + (* A small helper for "leave" types *) + let wrap ty = if inside_mut then Some ty else None in + match ty with + | T.Adt (type_id, _, tys) -> ( + match type_id with + | T.AdtId _ | Assumed (T.Vec | T.Option) -> + (* Don't accept ADTs (which are not tuples) with borrows for now *) + assert (not (TypesUtils.ty_has_borrows types_infos ty)); + let type_id = + match type_id with + | T.AdtId id -> AdtId id + | T.Assumed T.Vec -> Assumed Vec + | T.Assumed T.Option -> Assumed Option + | T.Tuple | T.Assumed T.Box -> raise (Failure "Unreachable") + in + if inside_mut then + let tys_t = List.filter_map translate tys in + Some (Adt (type_id, tys_t)) + else None + | Assumed T.Box -> ( + (* Don't accept ADTs (which are not tuples) with borrows for now *) + assert (not (TypesUtils.ty_has_borrows types_infos ty)); + (* Eliminate the box *) + match tys with + | [ bty ] -> translate bty + | _ -> + failwith "Unreachable: boxes receive exactly one type parameter") + | T.Tuple -> ( + (* Tuples can contain borrows (which we eliminated) *) + let tys_t = List.filter_map translate tys in + match tys_t with + | [] -> None + | _ -> + (* Note that if there is exactly one type, [mk_simpl_tuple_ty] + * is the identity *) + Some (mk_simpl_tuple_ty tys_t))) + | TypeVar vid -> wrap (TypeVar vid) + | Bool -> wrap Bool + | Char -> wrap Char + | Never -> raise (Failure "Unreachable") + | Integer int_ty -> wrap (Integer int_ty) + | Str -> wrap Str + | Array ty -> ( + assert (not (TypesUtils.ty_has_borrows types_infos ty)); + match translate ty with None -> None | Some ty -> Some (Array ty)) + | Slice ty -> ( + assert (not (TypesUtils.ty_has_borrows types_infos ty)); + match translate ty with None -> None | Some ty -> Some (Slice ty)) + | Ref (r, rty, rkind) -> ( + match rkind with + | T.Shared -> + (* Ignore shared references, unless we are below a mutable borrow *) + if inside_mut then translate rty else None + | T.Mut -> + (* Dive in, remembering the fact that we are inside a mutable borrow *) + let inside_mut = true in + if keep_region r then + translate_back_ty types_infos keep_region inside_mut rty + else None) + +(** Simply calls [translate_back_ty] *) +let ctx_translate_back_ty (ctx : bs_ctx) (keep_region : 'r -> bool) + (inside_mut : bool) (ty : 'r T.ty) : ty option = + let types_infos = ctx.type_context.types_infos in + translate_back_ty types_infos keep_region inside_mut ty + +(** List the ancestors of an abstraction *) +let list_ancestor_abstractions_ids (ctx : bs_ctx) (abs : V.abs) : + V.AbstractionId.id list = + (* We could do something more "elegant" without references, but it is + * so much simpler to use references... *) + let abs_set = ref V.AbstractionId.Set.empty in + let rec gather (abs_id : V.AbstractionId.id) : unit = + if V.AbstractionId.Set.mem abs_id !abs_set then () + else ( + abs_set := V.AbstractionId.Set.add abs_id !abs_set; + let abs, _ = V.AbstractionId.Map.find abs_id ctx.abstractions in + List.iter gather abs.original_parents) + in + List.iter gather abs.original_parents; + let ids = !abs_set in + (* List the ancestors, in the proper order *) + let call_info = V.FunCallId.Map.find abs.call_id ctx.calls in + List.filter + (fun id -> V.AbstractionId.Set.mem id ids) + call_info.forward.abstractions + +let list_ancestor_abstractions (ctx : bs_ctx) (abs : V.abs) : + (V.abs * texpression list) list = + let abs_ids = list_ancestor_abstractions_ids ctx abs in + List.map (fun id -> V.AbstractionId.Map.find id ctx.abstractions) abs_ids + +(** Small utility. *) +let get_fun_effect_info (fun_infos : FA.fun_info A.FunDeclId.Map.t) + (fun_id : A.fun_id) (gid : T.RegionGroupId.id option) : fun_effect_info = + match fun_id with + | A.Regular fid -> + let info = A.FunDeclId.Map.find fid fun_infos in + let input_state = info.stateful in + let output_state = input_state && gid = None in + { can_fail = info.can_fail; input_state; output_state } + | A.Assumed aid -> + { + can_fail = Assumed.assumed_can_fail aid; + input_state = false; + output_state = false; + } + +(** Translate a function signature. + + Note that the function also takes a list of names for the inputs, and + computes, for every output for the backward functions, a corresponding + name (outputs for backward functions come from borrows in the inputs + of the forward function). + *) +let translate_fun_sig (fun_infos : FA.fun_info A.FunDeclId.Map.t) + (fun_id : A.fun_id) (types_infos : TA.type_infos) (sg : A.fun_sig) + (input_names : string option list) (bid : T.RegionGroupId.id option) : + fun_sig_named_outputs = + (* Retrieve the list of parent backward functions *) + let gid, parents = + match bid with + | None -> (None, T.RegionGroupId.Set.empty) + | Some bid -> + let parents = list_parent_region_groups sg bid in + (Some bid, parents) + in + (* List the inputs for: + * - the forward function + * - the parent backward functions, in proper order + * - the current backward function (if it is a backward function) + *) + let fwd_inputs = List.map (translate_fwd_ty types_infos) sg.inputs in + (* For the backward functions: for now we don't supported nested borrows, + * so just check that there aren't parent regions *) + assert (T.RegionGroupId.Set.is_empty parents); + (* Small helper to translate types for backward functions *) + let translate_back_ty_for_gid (gid : T.RegionGroupId.id) : T.sty -> ty option + = + let rg = T.RegionGroupId.nth sg.regions_hierarchy gid in + let regions = T.RegionVarId.Set.of_list rg.regions in + let keep_region r = + match r with + | T.Static -> raise Unimplemented + | T.Var r -> T.RegionVarId.Set.mem r regions + in + let inside_mut = false in + translate_back_ty types_infos keep_region inside_mut + in + (* Compute the additinal inputs for the current function, if it is a backward + * function *) + let back_inputs = + match gid with + | None -> [] + | Some gid -> + (* For now, we don't allow nested borrows, so the additional inputs to the + backward function can only come from borrows that were returned like + in (for the backward function we introduce for 'a): + {[ + fn f<'a>(...) -> &'a mut u32; + ]} + Upon ending the abstraction for 'a, we need to get back the borrow + the function returned. + *) + List.filter_map (translate_back_ty_for_gid gid) [ sg.output ] + in + (* Does the function take a state as input, does it return a state and can + * it fail? *) + let effect_info = get_fun_effect_info fun_infos fun_id bid in + (* *) + let state_ty = if effect_info.input_state then [ mk_state_ty ] else [] in + (* Concatenate the inputs, in the following order: + * - forward inputs + * - state input + * - backward inputs + *) + let inputs = List.concat [ fwd_inputs; state_ty; back_inputs ] in + (* Outputs *) + let output_names, doutputs = + match gid with + | None -> + (* This is a forward function: there is one (unnamed) output *) + ([ None ], [ translate_fwd_ty types_infos sg.output ]) + | Some gid -> + (* This is a backward function: there might be several outputs. + The outputs are the borrows inside the regions of the abstractions + and which are present in the input values. For instance, see: + {[ + fn f<'a>(x : &'a mut u32) -> ...; + ]} + Upon ending the abstraction for 'a, we give back the borrow which + was consumed through the [x] parameter. + *) + let outputs = + List.map + (fun (name, input_ty) -> + (name, translate_back_ty_for_gid gid input_ty)) + (List.combine input_names sg.inputs) + in + (* Filter *) + let outputs = + List.filter (fun (_, opt_ty) -> Option.is_some opt_ty) outputs + in + let outputs = + List.map (fun (name, opt_ty) -> (name, Option.get opt_ty)) outputs + in + List.split outputs + in + (* Create the return type *) + let output = + (* Group the outputs together *) + let output = mk_simpl_tuple_ty doutputs in + (* Add the output state *) + let output = + if effect_info.output_state then mk_simpl_tuple_ty [ mk_state_ty; output ] + else output + in + (* Wrap in a result type *) + if effect_info.can_fail then mk_result_ty output else output + in + (* Type parameters *) + let type_params = sg.type_params in + (* Return *) + let info = + { + num_fwd_inputs = List.length fwd_inputs; + num_back_inputs = + (if bid = None then None else Some (List.length back_inputs)); + effect_info; + } + in + let sg = { type_params; inputs; output; doutputs; info } in + { sg; output_names } + +let bs_ctx_fresh_state_var (ctx : bs_ctx) : bs_ctx * typed_pattern = + (* Generate the fresh variable *) + let id, var_counter = VarId.fresh ctx.var_counter in + let var = + { id; basename = Some ConstStrings.state_basename; ty = mk_state_ty } + in + let state_var = mk_typed_pattern_from_var var None in + (* Update the context *) + let ctx = { ctx with var_counter; state_var = id } in + (* Return *) + (ctx, state_var) + +let fresh_named_var_for_symbolic_value (basename : string option) + (sv : V.symbolic_value) (ctx : bs_ctx) : bs_ctx * var = + (* Generate the fresh variable *) + let id, var_counter = VarId.fresh ctx.var_counter in + let ty = ctx_translate_fwd_ty ctx sv.sv_ty in + let var = { id; basename; ty } in + (* Insert in the map *) + let sv_to_var = V.SymbolicValueId.Map.add sv.sv_id var ctx.sv_to_var in + (* Update the context *) + let ctx = { ctx with var_counter; sv_to_var } in + (* Return *) + (ctx, var) + +let fresh_var_for_symbolic_value (sv : V.symbolic_value) (ctx : bs_ctx) : + bs_ctx * var = + fresh_named_var_for_symbolic_value None sv ctx + +let fresh_vars_for_symbolic_values (svl : V.symbolic_value list) (ctx : bs_ctx) + : bs_ctx * var list = + List.fold_left_map (fun ctx sv -> fresh_var_for_symbolic_value sv ctx) ctx svl + +let fresh_named_vars_for_symbolic_values + (svl : (string option * V.symbolic_value) list) (ctx : bs_ctx) : + bs_ctx * var list = + List.fold_left_map + (fun ctx (name, sv) -> fresh_named_var_for_symbolic_value name sv ctx) + ctx svl + +(** This generates a fresh variable **which is not to be linked to any symbolic value** *) +let fresh_var (basename : string option) (ty : ty) (ctx : bs_ctx) : bs_ctx * var + = + (* Generate the fresh variable *) + let id, var_counter = VarId.fresh ctx.var_counter in + let var = { id; basename; ty } in + (* Update the context *) + let ctx = { ctx with var_counter } in + (* Return *) + (ctx, var) + +let fresh_vars (vars : (string option * ty) list) (ctx : bs_ctx) : + bs_ctx * var list = + List.fold_left_map (fun ctx (name, ty) -> fresh_var name ty ctx) ctx vars + +let lookup_var_for_symbolic_value (sv : V.symbolic_value) (ctx : bs_ctx) : var = + V.SymbolicValueId.Map.find sv.sv_id ctx.sv_to_var + +(** Peel boxes as long as the value is of the form [Box] *) +let rec unbox_typed_value (v : V.typed_value) : V.typed_value = + match (v.value, v.ty) with + | V.Adt av, T.Adt (T.Assumed T.Box, _, _) -> ( + match av.field_values with + | [ bv ] -> unbox_typed_value bv + | _ -> raise (Failure "Unreachable")) + | _ -> v + +(** Translate a typed value. + + It is used, for instance, on values used as inputs for function calls. + + **IMPORTANT**: this function makes the assumption that the typed value + doesn't contain ⊥. This means in particular that symbolic values don't + contain ended regions. + + TODO: we might want to remember in the symbolic AST the set of ended + regions, at the points where we need it, for sanity checks (though the + sanity checks in the symbolic interpreter should be enough). + The points where we need this set so far: + - function call + - end abstraction + - return + *) +let rec typed_value_to_texpression (ctx : bs_ctx) (v : V.typed_value) : + texpression = + (* We need to ignore boxes *) + let v = unbox_typed_value v in + let translate = typed_value_to_texpression ctx in + (* Translate the type *) + let ty = ctx_translate_fwd_ty ctx v.ty in + (* Translate the value *) + let value = + match v.value with + | V.Concrete cv -> { e = Const cv; ty } + | Adt av -> ( + let variant_id = av.variant_id in + let field_values = List.map translate av.field_values in + (* Eliminate the tuple wrapper if it is a tuple with exactly one field *) + match v.ty with + | T.Adt (T.Tuple, _, _) -> + assert (variant_id = None); + mk_simpl_tuple_texpression field_values + | _ -> + (* Retrieve the type and the translated type arguments from the + * translated type (simpler this way) *) + let adt_id, type_args = + match ty with + | Adt (type_id, tys) -> (type_id, tys) + | _ -> raise (Failure "Unreachable") + in + (* Create the constructor *) + let qualif_id = AdtCons { adt_id; variant_id = av.variant_id } in + let qualif = { id = qualif_id; type_args } in + let cons_e = Qualif qualif in + let field_tys = + List.map (fun (v : texpression) -> v.ty) field_values + in + let cons_ty = mk_arrows field_tys ty in + let cons = { e = cons_e; ty = cons_ty } in + (* Apply the constructor *) + mk_apps cons field_values) + | Bottom -> raise (Failure "Unreachable") + | Loan lc -> ( + match lc with + | SharedLoan (_, v) -> translate v + | MutLoan _ -> raise (Failure "Unreachable")) + | Borrow bc -> ( + match bc with + | V.SharedBorrow (mv, _) -> + (* The meta-value stored in the shared borrow was added especially + * for this case (because we can't use the borrow id for lookups) *) + translate mv + | V.InactivatedMutBorrow (mv, _) -> + (* Same as for shared borrows. However, note that we use inactivated borrows + * only in meta-data: a value actually *used in the translation* can't come + * from an unpromoted inactivated borrow *) + translate mv + | V.MutBorrow (_, v) -> + (* Borrows are the identity in the extraction *) + translate v) + | Symbolic sv -> + let var = lookup_var_for_symbolic_value sv ctx in + mk_texpression_from_var var + in + (* Debugging *) + log#ldebug + (lazy + ("typed_value_to_texpression: result:" ^ "\n- input value:\n" + ^ V.show_typed_value v ^ "\n- translated expression:\n" + ^ show_texpression value)); + (* Sanity check *) + type_check_texpression ctx value; + (* Return *) + value + +(** Explore an abstraction value and convert it to a consumed value + by collecting all the meta-values from the ended *loans*. + + Consumed values are rvalues, because when an abstraction ends, we + introduce a call to a backward function in the synthesized program, + which takes as inputs those consumed values: + {[ + // Rust: + fn choose<'a>(b: bool, x : &'a mut u32, y : &'a mut u32) -> &'a mut u32; + + // Synthesis: + let ... = choose_back b x y nz in + ^^ + ]} + *) +let rec typed_avalue_to_consumed (ctx : bs_ctx) (av : V.typed_avalue) : + texpression option = + let translate = typed_avalue_to_consumed ctx in + let value = + match av.value with + | AConcrete _ -> raise (Failure "Unreachable") + | AAdt adt_v -> ( + (* Translate the field values *) + let field_values = List.filter_map translate adt_v.field_values in + (* For now, only tuples can contain borrows *) + let adt_id, _, _ = TypesUtils.ty_as_adt av.ty in + match adt_id with + | T.AdtId _ | T.Assumed (T.Box | T.Vec | T.Option) -> + assert (field_values = []); + None + | T.Tuple -> + (* Return *) + if field_values = [] then None + else + (* Note that if there is exactly one field value, + * [mk_simpl_tuple_rvalue] is the identity *) + let rv = mk_simpl_tuple_texpression field_values in + Some rv) + | ABottom -> raise (Failure "Unreachable") + | ALoan lc -> aloan_content_to_consumed ctx lc + | ABorrow bc -> aborrow_content_to_consumed ctx bc + | ASymbolic aproj -> aproj_to_consumed ctx aproj + | AIgnored -> None + in + (* Sanity check - Rk.: we do this at every recursive call, which is a bit + * expansive... *) + (match value with + | None -> () + | Some value -> type_check_texpression ctx value); + (* Return *) + value + +and aloan_content_to_consumed (ctx : bs_ctx) (lc : V.aloan_content) : + texpression option = + match lc with + | AMutLoan (_, _) | ASharedLoan (_, _, _) -> raise (Failure "Unreachable") + | AEndedMutLoan { child = _; given_back = _; given_back_meta } -> + (* Return the meta-value *) + Some (typed_value_to_texpression ctx given_back_meta) + | AEndedSharedLoan (_, _) -> + (* We don't dive into shared loans: there is nothing to give back + * inside (note that there could be a mutable borrow in the shared + * value, pointing to a mutable loan in the child avalue, but this + * borrow is in practice immutable) *) + None + | AIgnoredMutLoan (_, _) -> + (* There can be *inner* not ended mutable loans, but not outer ones *) + raise (Failure "Unreachable") + | AEndedIgnoredMutLoan _ -> + (* This happens with nested borrows: we need to dive in *) + raise Unimplemented + | AIgnoredSharedLoan _ -> + (* Ignore *) + None + +and aborrow_content_to_consumed (_ctx : bs_ctx) (bc : V.aborrow_content) : + texpression option = + match bc with + | V.AMutBorrow (_, _, _) | ASharedBorrow _ | AIgnoredMutBorrow (_, _) -> + raise (Failure "Unreachable") + | AEndedMutBorrow (_, _) -> + (* We collect consumed values: ignore *) + None + | AEndedIgnoredMutBorrow _ -> + (* This happens with nested borrows: we need to dive in *) + raise Unimplemented + | AEndedSharedBorrow | AProjSharedBorrow _ -> + (* Ignore *) + None + +and aproj_to_consumed (ctx : bs_ctx) (aproj : V.aproj) : texpression option = + match aproj with + | V.AEndedProjLoans (msv, []) -> + (* The symbolic value was left unchanged *) + let var = lookup_var_for_symbolic_value msv ctx in + Some (mk_texpression_from_var var) + | V.AEndedProjLoans (_, [ (mnv, child_aproj) ]) -> + assert (child_aproj = AIgnoredProjBorrows); + (* The symbolic value was updated *) + let var = lookup_var_for_symbolic_value mnv ctx in + Some (mk_texpression_from_var var) + | V.AEndedProjLoans (_, _) -> + (* The symbolic value was updated, and the given back values come from sevearl + * abstractions *) + raise Unimplemented + | AEndedProjBorrows _ -> (* We consider consumed values *) None + | AIgnoredProjBorrows | AProjLoans (_, _) | AProjBorrows (_, _) -> + raise (Failure "Unreachable") + +(** Convert the abstraction values in an abstraction to consumed values. + + See [typed_avalue_to_consumed]. + *) +let abs_to_consumed (ctx : bs_ctx) (abs : V.abs) : texpression list = + log#ldebug (lazy ("abs_to_consumed:\n" ^ abs_to_string ctx abs)); + List.filter_map (typed_avalue_to_consumed ctx) abs.avalues + +let translate_mprojection_elem (pe : E.projection_elem) : + mprojection_elem option = + match pe with + | Deref | DerefBox -> None + | Field (pkind, field_id) -> Some { pkind; field_id } + +let translate_mprojection (p : E.projection) : mprojection = + List.filter_map translate_mprojection_elem p + +(** Translate a "meta"-place *) +let translate_mplace (p : S.mplace) : mplace = + let var_id = p.bv.index in + let name = p.bv.name in + let projection = translate_mprojection p.projection in + { var_id; name; projection } + +let translate_opt_mplace (p : S.mplace option) : mplace option = + match p with None -> None | Some p -> Some (translate_mplace p) + +(** Explore an abstraction value and convert it to a given back value + by collecting all the meta-values from the ended *borrows*. + + Given back values are patterns, because when an abstraction ends, we + introduce a call to a backward function in the synthesized program, + which introduces new values: + {[ + let (nx, ny) = f_back ... in + ^^^^^^^^ + ]} + + [mp]: it is possible to provide some meta-place information, to guide + the heuristics which later find pretty names for the variables. + *) +let rec typed_avalue_to_given_back (mp : mplace option) (av : V.typed_avalue) + (ctx : bs_ctx) : bs_ctx * typed_pattern option = + let ctx, value = + match av.value with + | AConcrete _ -> raise (Failure "Unreachable") + | AAdt adt_v -> ( + (* Translate the field values *) + (* For now we forget the meta-place information so that it doesn't get used + * by several fields (which would then all have the same name...), but we + * might want to do something smarter *) + let mp = None in + let ctx, field_values = + List.fold_left_map + (fun ctx fv -> typed_avalue_to_given_back mp fv ctx) + ctx adt_v.field_values + in + let field_values = List.filter_map (fun x -> x) field_values in + (* For now, only tuples can contain borrows - note that if we gave + * something like a [&mut Vec] to a function, we give give back the + * vector value upon visiting the "abstraction borrow" node *) + let adt_id, _, _ = TypesUtils.ty_as_adt av.ty in + match adt_id with + | T.AdtId _ | T.Assumed (T.Box | T.Vec | T.Option) -> + assert (field_values = []); + (ctx, None) + | T.Tuple -> + (* Return *) + let variant_id = adt_v.variant_id in + assert (variant_id = None); + if field_values = [] then (ctx, None) + else + (* Note that if there is exactly one field value, [mk_simpl_tuple_pattern] + * is the identity *) + let lv = mk_simpl_tuple_pattern field_values in + (ctx, Some lv)) + | ABottom -> raise (Failure "Unreachable") + | ALoan lc -> aloan_content_to_given_back mp lc ctx + | ABorrow bc -> aborrow_content_to_given_back mp bc ctx + | ASymbolic aproj -> aproj_to_given_back mp aproj ctx + | AIgnored -> (ctx, None) + in + (* Sanity check - Rk.: we do this at every recursive call, which is a bit + * expansive... *) + (match value with None -> () | Some value -> type_check_pattern ctx value); + (* Return *) + (ctx, value) + +and aloan_content_to_given_back (_mp : mplace option) (lc : V.aloan_content) + (ctx : bs_ctx) : bs_ctx * typed_pattern option = + match lc with + | AMutLoan (_, _) | ASharedLoan (_, _, _) -> raise (Failure "Unreachable") + | AEndedMutLoan { child = _; given_back = _; given_back_meta = _ } + | AEndedSharedLoan (_, _) -> + (* We consider given back values, and thus ignore those *) + (ctx, None) + | AIgnoredMutLoan (_, _) -> + (* There can be *inner* not ended mutable loans, but not outer ones *) + raise (Failure "Unreachable") + | AEndedIgnoredMutLoan _ -> + (* This happens with nested borrows: we need to dive in *) + raise Unimplemented + | AIgnoredSharedLoan _ -> + (* Ignore *) + (ctx, None) + +and aborrow_content_to_given_back (mp : mplace option) (bc : V.aborrow_content) + (ctx : bs_ctx) : bs_ctx * typed_pattern option = + match bc with + | V.AMutBorrow (_, _, _) | ASharedBorrow _ | AIgnoredMutBorrow (_, _) -> + raise (Failure "Unreachable") + | AEndedMutBorrow (msv, _) -> + (* Return the meta-symbolic-value *) + let ctx, var = fresh_var_for_symbolic_value msv ctx in + (ctx, Some (mk_typed_pattern_from_var var mp)) + | AEndedIgnoredMutBorrow _ -> + (* This happens with nested borrows: we need to dive in *) + raise Unimplemented + | AEndedSharedBorrow | AProjSharedBorrow _ -> + (* Ignore *) + (ctx, None) + +and aproj_to_given_back (mp : mplace option) (aproj : V.aproj) (ctx : bs_ctx) : + bs_ctx * typed_pattern option = + match aproj with + | V.AEndedProjLoans (_, child_projs) -> + (* There may be children borrow projections in case of nested borrows, + * in which case we need to dive in - we disallow nested borrows for now *) + assert ( + List.for_all + (fun (_, aproj) -> aproj = V.AIgnoredProjBorrows) + child_projs); + (ctx, None) + | AEndedProjBorrows mv -> + (* Return the meta-value *) + let ctx, var = fresh_var_for_symbolic_value mv ctx in + (ctx, Some (mk_typed_pattern_from_var var mp)) + | AIgnoredProjBorrows | AProjLoans (_, _) | AProjBorrows (_, _) -> + raise (Failure "Unreachable") + +(** Convert the abstraction values in an abstraction to given back values. + + See [typed_avalue_to_given_back]. + *) +let abs_to_given_back (mpl : mplace option list) (abs : V.abs) (ctx : bs_ctx) : + bs_ctx * typed_pattern list = + let avalues = List.combine mpl abs.avalues in + let ctx, values = + List.fold_left_map + (fun ctx (mp, av) -> typed_avalue_to_given_back mp av ctx) + ctx avalues + in + let values = List.filter_map (fun x -> x) values in + (ctx, values) + +(** Simply calls [abs_to_given_back] *) +let abs_to_given_back_no_mp (abs : V.abs) (ctx : bs_ctx) : + bs_ctx * typed_pattern list = + let mpl = List.map (fun _ -> None) abs.avalues in + abs_to_given_back mpl abs ctx + +(** Return the ordered list of the (transitive) parents of a given abstraction. + + Is used for instance when collecting the input values given to all the + parent functions, in order to properly instantiate an + *) +let get_abs_ancestors (ctx : bs_ctx) (abs : V.abs) : + S.call * (V.abs * texpression list) list = + let call_info = V.FunCallId.Map.find abs.call_id ctx.calls in + let abs_ancestors = list_ancestor_abstractions ctx abs in + (call_info.forward, abs_ancestors) + +let rec translate_expression (config : config) (e : S.expression) (ctx : bs_ctx) + : texpression = + match e with + | S.Return opt_v -> translate_return opt_v ctx + | Panic -> translate_panic ctx + | FunCall (call, e) -> translate_function_call config call e ctx + | EndAbstraction (abs, e) -> translate_end_abstraction config abs e ctx + | EvalGlobal (gid, sv, e) -> translate_global_eval config gid sv e ctx + | Expansion (p, sv, exp) -> translate_expansion config p sv exp ctx + | Meta (meta, e) -> translate_meta config meta e ctx + +and translate_panic (ctx : bs_ctx) : texpression = + (* Here we use the function return type - note that it is ok because + * we don't match on panics which happen inside the function body - + * but it won't be true anymore once we translate individual blocks *) + (* If we use a state monad, we need to add a lambda for the state variable *) + (* Note that only forward functions return a state *) + let output_ty = mk_simpl_tuple_ty ctx.sg.doutputs in + if ctx.sg.info.effect_info.output_state then + (* Create the [Fail] value *) + let ret_ty = mk_simpl_tuple_ty [ mk_state_ty; output_ty ] in + let ret_v = mk_result_fail_texpression ret_ty in + ret_v + else mk_result_fail_texpression output_ty + +and translate_return (opt_v : V.typed_value option) (ctx : bs_ctx) : texpression + = + (* There are two cases: + - either we are translating a forward function, in which case the optional + value should be [Some] (it is the returned value) + - or we are translating a backward function, in which case it should be [None] + *) + match ctx.bid with + | None -> + (* Forward function *) + let v = Option.get opt_v in + let v = typed_value_to_texpression ctx v in + (* We may need to return a state + * - error-monad: Return x + * - state-error: Return (state, x) + * *) + if ctx.sg.info.effect_info.output_state then + let state_var = + { + id = ctx.state_var; + basename = Some ConstStrings.state_basename; + ty = mk_state_ty; + } + in + let state_rvalue = mk_texpression_from_var state_var in + mk_result_return_texpression + (mk_simpl_tuple_texpression [ state_rvalue; v ]) + else mk_result_return_texpression v + | Some bid -> + (* Backward function *) + (* Sanity check *) + assert (opt_v = None); + assert (not ctx.sg.info.effect_info.output_state); + (* We simply need to return the variables in which we stored the values + * we need to give back. + * See the explanations for the [SynthInput] case in [translate_end_abstraction] *) + let backward_outputs = + T.RegionGroupId.Map.find bid ctx.backward_outputs + in + let field_values = List.map mk_texpression_from_var backward_outputs in + (* Backward functions never return a state *) + (* TODO: we should use a [fail] function, it would be cleaner *) + let ret_value = mk_simpl_tuple_texpression field_values in + let ret_value = mk_result_return_texpression ret_value in + ret_value + +and translate_function_call (config : config) (call : S.call) (e : S.expression) + (ctx : bs_ctx) : texpression = + (* Translate the function call *) + let type_args = List.map (ctx_translate_fwd_ty ctx) call.type_params in + let args = + let args = List.map (typed_value_to_texpression ctx) call.args in + let args_mplaces = List.map translate_opt_mplace call.args_places in + List.map + (fun (arg, mp) -> mk_opt_mplace_texpression mp arg) + (List.combine args args_mplaces) + in + let dest_mplace = translate_opt_mplace call.dest_place in + let ctx, dest = fresh_var_for_symbolic_value call.dest ctx in + (* Retrieve the function id, and register the function call in the context + * if necessary. *) + let ctx, fun_id, effect_info, args, out_state = + match call.call_id with + | S.Fun (fid, call_id) -> + (* Regular function call *) + let func = Regular (fid, None) in + (* Retrieve the effect information about this function (can fail, + * takes a state as input, etc.) *) + let effect_info = + get_fun_effect_info ctx.fun_context.fun_infos fid None + in + (* Add the state input argument *) + let args = + if effect_info.input_state then + let state_var = { e = Var ctx.state_var; ty = mk_state_ty } in + List.append args [ state_var ] + else args + in + (* Generate a fresh state variable if the function call introduces + * a new variable *) + let ctx, out_state = + if effect_info.input_state then + let ctx, var = bs_ctx_fresh_state_var ctx in + (ctx, Some var) + else (ctx, None) + in + (* Register the function call *) + let ctx = bs_ctx_register_forward_call call_id call args ctx in + (ctx, func, effect_info, args, out_state) + | S.Unop E.Not -> + let effect_info = + { can_fail = false; input_state = false; output_state = false } + in + (ctx, Unop Not, effect_info, args, None) + | S.Unop E.Neg -> ( + match args with + | [ arg ] -> + let int_ty = ty_as_integer arg.ty in + (* Note that negation can lead to an overflow and thus fail (it + * is thus monadic) *) + let effect_info = + { can_fail = true; input_state = false; output_state = false } + in + (ctx, Unop (Neg int_ty), effect_info, args, None) + | _ -> raise (Failure "Unreachable")) + | S.Unop (E.Cast (src_ty, tgt_ty)) -> + (* Note that cast can fail *) + let effect_info = + { can_fail = true; input_state = false; output_state = false } + in + (ctx, Unop (Cast (src_ty, tgt_ty)), effect_info, args, None) + | S.Binop binop -> ( + match args with + | [ arg0; arg1 ] -> + let int_ty0 = ty_as_integer arg0.ty in + let int_ty1 = ty_as_integer arg1.ty in + assert (int_ty0 = int_ty1); + let effect_info = + { + can_fail = ExpressionsUtils.binop_can_fail binop; + input_state = false; + output_state = false; + } + in + (ctx, Binop (binop, int_ty0), effect_info, args, None) + | _ -> raise (Failure "Unreachable")) + in + let dest_v = + let dest = mk_typed_pattern_from_var dest dest_mplace in + match out_state with + | None -> dest + | Some out_state -> mk_simpl_tuple_pattern [ out_state; dest ] + in + let func = { id = Func fun_id; type_args } in + let input_tys = (List.map (fun (x : texpression) -> x.ty)) args in + let ret_ty = + if effect_info.can_fail then mk_result_ty dest_v.ty else dest_v.ty + in + let func_ty = mk_arrows input_tys ret_ty in + let func = { e = Qualif func; ty = func_ty } in + let call = mk_apps func args in + (* Translate the next expression *) + let next_e = translate_expression config e ctx in + (* Put together *) + mk_let effect_info.can_fail dest_v call next_e + +and translate_end_abstraction (config : config) (abs : V.abs) (e : S.expression) + (ctx : bs_ctx) : texpression = + log#ldebug + (lazy + ("translate_end_abstraction: abstraction kind: " + ^ V.show_abs_kind abs.kind)); + match abs.kind with + | V.SynthInput -> + (* When we end an input abstraction, this input abstraction gets back + * the borrows which it introduced in the context through the input + * values: by listing those values, we get the values which are given + * back by one of the backward functions we are synthesizing. *) + (* Note that we don't support nested borrows for now: if we find + * an ended synthesized input abstraction, it must be the one corresponding + * to the backward function wer are synthesizing, it can't be the one + * for a parent backward function. + *) + let bid = Option.get ctx.bid in + assert (abs.back_id = bid); + + (* The translation is done as follows: + * - for a given backward function, we choose a set of variables [v_i] + * - when we detect the ended input abstraction which corresponds + * to the backward function, and which consumed the values [consumed_i], + * we introduce: + * {[ + * let v_i = consumed_i in + * ... + * ]} + * Then, when we reach the [Return] node, we introduce: + * {[ + * (v_i) + * ]} + * *) + (* First, get the given back variables *) + let given_back_variables = + T.RegionGroupId.Map.find bid ctx.backward_outputs + in + (* Get the list of values consumed by the abstraction upon ending *) + let consumed_values = abs_to_consumed ctx abs in + (* Group the two lists *) + let variables_values = + List.combine given_back_variables consumed_values + in + (* Sanity check: the two lists match (same types) *) + List.iter + (fun (var, v) -> assert ((var : var).ty = (v : texpression).ty)) + variables_values; + (* Translate the next expression *) + let next_e = translate_expression config e ctx in + (* Generate the assignemnts *) + let monadic = false in + List.fold_right + (fun (var, value) (e : texpression) -> + mk_let monadic (mk_typed_pattern_from_var var None) value e) + variables_values next_e + | V.FunCall -> + let call_info = V.FunCallId.Map.find abs.call_id ctx.calls in + let call = call_info.forward in + let type_args = List.map (ctx_translate_fwd_ty ctx) call.type_params in + (* Retrieve the original call and the parent abstractions *) + let _forward, backwards = get_abs_ancestors ctx abs in + (* Retrieve the values consumed when we called the forward function and + * ended the parent backward functions: those give us part of the input + * values (rmk: for now, as we disallow nested lifetimes, there can't be + * parent backward functions). + * Note that the forward inputs include the input state (if there is one). *) + let fwd_inputs = call_info.forward_inputs in + let back_ancestors_inputs = + List.concat (List.map (fun (_abs, args) -> args) backwards) + in + (* Retrieve the values consumed upon ending the loans inside this + * abstraction: those give us the remaining input values *) + let back_inputs = abs_to_consumed ctx abs in + let inputs = + List.concat [ fwd_inputs; back_ancestors_inputs; back_inputs ] + in + (* Retrieve the values given back by this function: those are the output + * values. We rely on the fact that there are no nested borrows to use the + * meta-place information from the input values given to the forward function + * (we need to add [None] for the return avalue) *) + let output_mpl = + List.append (List.map translate_opt_mplace call.args_places) [ None ] + in + let ctx, outputs = abs_to_given_back output_mpl abs ctx in + (* Group the output values together (note that for now, backward functions + * never return an output state) *) + let output = mk_simpl_tuple_pattern outputs in + (* Sanity check: the inputs and outputs have the proper number and the proper type *) + let fun_id = + match call.call_id with + | S.Fun (fun_id, _) -> fun_id + | Unop _ | Binop _ -> + (* Those don't have backward functions *) + raise (Failure "Unreachable") + in + + let inst_sg = + get_instantiated_fun_sig fun_id (Some abs.back_id) type_args ctx + in + log#ldebug + (lazy + ("\n- fun_id: " ^ A.show_fun_id fun_id ^ "\n- inputs (" + ^ string_of_int (List.length inputs) + ^ "): " + ^ String.concat ", " (List.map show_texpression inputs) + ^ "\n- inst_sg.inputs (" + ^ string_of_int (List.length inst_sg.inputs) + ^ "): " + ^ String.concat ", " (List.map show_ty inst_sg.inputs))); + List.iter + (fun (x, ty) -> assert ((x : texpression).ty = ty)) + (List.combine inputs inst_sg.inputs); + log#ldebug + (lazy + ("\n- outputs: " + ^ string_of_int (List.length outputs) + ^ "\n- expected outputs: " + ^ string_of_int (List.length inst_sg.doutputs))); + List.iter + (fun (x, ty) -> assert ((x : typed_pattern).ty = ty)) + (List.combine outputs inst_sg.doutputs); + (* Retrieve the function id, and register the function call in the context + * if necessary *) + let ctx, func = bs_ctx_register_backward_call abs back_inputs ctx in + (* Translate the next expression *) + let next_e = translate_expression config e ctx in + (* Put everything together *) + let args_mplaces = List.map (fun _ -> None) inputs in + let args = + List.map + (fun (arg, mp) -> mk_opt_mplace_texpression mp arg) + (List.combine inputs args_mplaces) + in + let effect_info = + get_fun_effect_info ctx.fun_context.fun_infos fun_id (Some abs.back_id) + in + let input_tys = (List.map (fun (x : texpression) -> x.ty)) args in + let ret_ty = + if effect_info.can_fail then mk_result_ty output.ty else output.ty + in + let func_ty = mk_arrows input_tys ret_ty in + let func = { id = Func func; type_args } in + let func = { e = Qualif func; ty = func_ty } in + let call = mk_apps func args in + (* **Optimization**: + * ================= + * We do a small optimization here: if the backward function doesn't + * have any output, we don't introduce any function call. + * See the comment in [config]. + *) + if config.filter_useless_back_calls && outputs = [] then ( + (* No outputs - we do a small sanity check: the backward function + * should have exactly the same number of inputs as the forward: + * this number can be different only if the forward function returned + * a value containing mutable borrows, which can't be the case... *) + assert (List.length inputs = List.length fwd_inputs); + next_e) + else mk_let effect_info.can_fail output call next_e + | V.SynthRet -> + (* If we end the abstraction which consumed the return value of the function + we are synthesizing, we get back the borrows which were inside. Those borrows + are actually input arguments of the backward function we are synthesizing. + So we simply need to introduce proper let bindings. + + For instance: + {[ + fn id<'a>(x : &'a mut u32) -> &'a mut u32 { + x + } + ]} + + Upon ending the return abstraction for 'a, we get back the borrow for [x]. + This new value is the second argument of the backward function: + {[ + let id_back x nx = nx + ]} + + In practice, upon ending this abstraction we introduce a useless + let-binding: + {[ + let id_back x nx = + let s = nx in // the name [s] is not important (only collision matters) + ... + ]} + + This let-binding later gets inlined, during a micro-pass. + *) + (* First, retrieve the list of variables used for the inputs for the + * backward function *) + let inputs = T.RegionGroupId.Map.find abs.back_id ctx.backward_inputs in + (* Retrieve the values consumed upon ending the loans inside this + * abstraction: as there are no nested borrows, there should be none. *) + let consumed = abs_to_consumed ctx abs in + assert (consumed = []); + (* Retrieve the values given back upon ending this abstraction - note that + * we don't provide meta-place information, because those assignments will + * be inlined anyway... *) + log#ldebug (lazy ("abs: " ^ abs_to_string ctx abs)); + let ctx, given_back = abs_to_given_back_no_mp abs ctx in + (* Link the inputs to those given back values - note that this also + * checks we have the same number of values, of course *) + let given_back_inputs = List.combine given_back inputs in + (* Sanity check *) + List.iter + (fun ((given_back, input) : typed_pattern * var) -> + log#ldebug + (lazy + ("\n- given_back ty: " + ^ ty_to_string ctx given_back.ty + ^ "\n- sig input ty: " ^ ty_to_string ctx input.ty)); + assert (given_back.ty = input.ty)) + given_back_inputs; + (* Translate the next expression *) + let next_e = translate_expression config e ctx in + (* Generate the assignments *) + let monadic = false in + List.fold_right + (fun (given_back, input_var) e -> + mk_let monadic given_back (mk_texpression_from_var input_var) e) + given_back_inputs next_e + +and translate_global_eval (config : config) (gid : A.GlobalDeclId.id) + (sval : V.symbolic_value) (e : S.expression) (ctx : bs_ctx) : texpression = + let ctx, var = fresh_var_for_symbolic_value sval ctx in + let decl = A.GlobalDeclId.Map.find gid ctx.global_context.llbc_global_decls in + let global_expr = { id = Global gid; type_args = [] } in + (* We use translate_fwd_ty to translate the global type *) + let ty = ctx_translate_fwd_ty ctx decl.ty in + let gval = { e = Qualif global_expr; ty } in + let e = translate_expression config e ctx in + mk_let false (mk_typed_pattern_from_var var None) gval e + +and translate_expansion (config : config) (p : S.mplace option) + (sv : V.symbolic_value) (exp : S.expansion) (ctx : bs_ctx) : texpression = + (* Translate the scrutinee *) + let scrutinee_var = lookup_var_for_symbolic_value sv ctx in + let scrutinee = mk_texpression_from_var scrutinee_var in + let scrutinee_mplace = translate_opt_mplace p in + (* Translate the branches *) + match exp with + | ExpandNoBranch (sexp, e) -> ( + match sexp with + | V.SeConcrete _ -> + (* Actually, we don't *register* symbolic expansions to constant + * values in the symbolic ADT *) + raise (Failure "Unreachable") + | SeMutRef (_, nsv) | SeSharedRef (_, nsv) -> + (* The (mut/shared) borrow type is extracted to identity: we thus simply + * introduce an reassignment *) + let ctx, var = fresh_var_for_symbolic_value nsv ctx in + let next_e = translate_expression config e ctx in + let monadic = false in + mk_let monadic + (mk_typed_pattern_from_var var None) + (mk_opt_mplace_texpression scrutinee_mplace scrutinee) + next_e + | SeAdt _ -> + (* Should be in the [ExpandAdt] case *) + raise (Failure "Unreachable")) + | ExpandAdt branches -> ( + (* We don't do the same thing if there is a branching or not *) + match branches with + | [] -> raise (Failure "Unreachable") + | [ (variant_id, svl, branch) ] -> ( + (* There is exactly one branch: no branching *) + let type_id, _, _ = TypesUtils.ty_as_adt sv.V.sv_ty in + let ctx, vars = fresh_vars_for_symbolic_values svl ctx in + let branch = translate_expression config branch ctx in + match type_id with + | T.AdtId adt_id -> + (* Detect if this is an enumeration or not *) + let tdef = bs_ctx_lookup_llbc_type_decl adt_id ctx in + let is_enum = type_decl_is_enum tdef in + if is_enum then + (* This is an enumeration: introduce an [ExpandEnum] let-binding *) + let variant_id = Option.get variant_id in + let lvars = + List.map (fun v -> mk_typed_pattern_from_var v None) vars + in + let lv = mk_adt_pattern scrutinee.ty variant_id lvars in + let monadic = false in + + mk_let monadic lv + (mk_opt_mplace_texpression scrutinee_mplace scrutinee) + branch + else + (* This is not an enumeration: introduce let-bindings for every + * field. + * We use the [dest] variable in order not to have to recompute + * the type of the result of the projection... *) + let adt_id, type_args = + match scrutinee.ty with + | Adt (adt_id, tys) -> (adt_id, tys) + | _ -> raise (Failure "Unreachable") + in + let gen_field_proj (field_id : FieldId.id) (dest : var) : + texpression = + let proj_kind = { adt_id; field_id } in + let qualif = { id = Proj proj_kind; type_args } in + let proj_e = Qualif qualif in + let proj_ty = mk_arrow scrutinee.ty dest.ty in + let proj = { e = proj_e; ty = proj_ty } in + mk_app proj scrutinee + in + let id_var_pairs = FieldId.mapi (fun fid v -> (fid, v)) vars in + let monadic = false in + List.fold_right + (fun (fid, var) e -> + let field_proj = gen_field_proj fid var in + mk_let monadic + (mk_typed_pattern_from_var var None) + field_proj e) + id_var_pairs branch + | T.Tuple -> + let vars = + List.map (fun x -> mk_typed_pattern_from_var x None) vars + in + let monadic = false in + mk_let monadic + (mk_simpl_tuple_pattern vars) + (mk_opt_mplace_texpression scrutinee_mplace scrutinee) + branch + | T.Assumed T.Box -> + (* There should be exactly one variable *) + let var = + match vars with + | [ v ] -> v + | _ -> raise (Failure "Unreachable") + in + (* We simply introduce an assignment - the box type is the + * identity when extracted ([box a == a]) *) + let monadic = false in + mk_let monadic + (mk_typed_pattern_from_var var None) + (mk_opt_mplace_texpression scrutinee_mplace scrutinee) + branch + | T.Assumed T.Vec -> + (* We can't expand vector values: we can access the fields only + * through the functions provided by the API (note that we don't + * know how to expand a vector, because it has a variable number + * of fields!) *) + failwith "Can't expand a vector value" + | T.Assumed T.Option -> + (* We shouldn't get there in the "one-branch" case: options have + * two variants *) + raise (Failure "Unreachable")) + | branches -> + let translate_branch (variant_id : T.VariantId.id option) + (svl : V.symbolic_value list) (branch : S.expression) : + match_branch = + (* There *must* be a variant id - otherwise there can't be several branches *) + let variant_id = Option.get variant_id in + let ctx, vars = fresh_vars_for_symbolic_values svl ctx in + let vars = + List.map (fun x -> mk_typed_pattern_from_var x None) vars + in + let pat_ty = scrutinee.ty in + let pat = mk_adt_pattern pat_ty variant_id vars in + let branch = translate_expression config branch ctx in + { pat; branch } + in + let branches = + List.map (fun (vid, svl, e) -> translate_branch vid svl e) branches + in + let e = + Switch + ( mk_opt_mplace_texpression scrutinee_mplace scrutinee, + Match branches ) + in + (* There should be at least one branch *) + let branch = List.hd branches in + let ty = branch.branch.ty in + (* Sanity check *) + assert (List.for_all (fun br -> br.branch.ty = ty) branches); + (* Return *) + { e; ty }) + | ExpandBool (true_e, false_e) -> + (* We don't need to update the context: we don't introduce any + * new values/variables *) + let true_e = translate_expression config true_e ctx in + let false_e = translate_expression config false_e ctx in + let e = + Switch + ( mk_opt_mplace_texpression scrutinee_mplace scrutinee, + If (true_e, false_e) ) + in + let ty = true_e.ty in + assert (ty = false_e.ty); + { e; ty } + | ExpandInt (int_ty, branches, otherwise) -> + let translate_branch ((v, branch_e) : V.scalar_value * S.expression) : + match_branch = + (* We don't need to update the context: we don't introduce any + * new values/variables *) + let branch = translate_expression config branch_e ctx in + let pat = mk_typed_pattern_from_constant_value (V.Scalar v) in + { pat; branch } + in + let branches = List.map translate_branch branches in + let otherwise = translate_expression config otherwise ctx in + let pat_ty = Integer int_ty in + let otherwise_pat : typed_pattern = { value = PatDummy; ty = pat_ty } in + let otherwise : match_branch = + { pat = otherwise_pat; branch = otherwise } + in + let all_branches = List.append branches [ otherwise ] in + let e = + Switch + ( mk_opt_mplace_texpression scrutinee_mplace scrutinee, + Match all_branches ) + in + let ty = otherwise.branch.ty in + assert ( + List.for_all (fun (br : match_branch) -> br.branch.ty = ty) branches); + { e; ty } + +and translate_meta (config : config) (meta : S.meta) (e : S.expression) + (ctx : bs_ctx) : texpression = + let next_e = translate_expression config e ctx in + let meta = + match meta with + | S.Assignment (lp, rv, rp) -> + let lp = translate_mplace lp in + let rv = typed_value_to_texpression ctx rv in + let rp = translate_opt_mplace rp in + Assignment (lp, rv, rp) + in + let e = Meta (meta, next_e) in + let ty = next_e.ty in + { e; ty } + +let translate_fun_decl (config : config) (ctx : bs_ctx) + (body : S.expression option) : fun_decl = + (* Translate *) + let def = ctx.fun_decl in + let bid = ctx.bid in + log#ldebug + (lazy + ("SymbolicToPure.translate_fun_decl: " + ^ Print.fun_name_to_string def.A.name + ^ " (" + ^ Print.option_to_string T.RegionGroupId.to_string bid + ^ ")")); + + (* Translate the declaration *) + let def_id = def.A.def_id in + let basename = def.name in + (* Lookup the signature *) + let signature = bs_ctx_lookup_local_function_sig def_id bid ctx in + (* Translate the body, if there is *) + let body = + match body with + | None -> None + | Some body -> + let body = translate_expression config body ctx in + (* Sanity check *) + type_check_texpression ctx body; + (* Introduce the input state, if necessary *) + let effect_info = + get_fun_effect_info ctx.fun_context.fun_infos (Regular def_id) bid + in + let input_state = + if effect_info.input_state then + [ + { + id = ctx.state_var; + basename = Some ConstStrings.state_basename; + ty = mk_state_ty; + }; + ] + else [] + in + (* Compute the list of (properly ordered) input variables *) + let backward_inputs : var list = + match bid with + | None -> [] + | Some back_id -> + let parents_ids = + list_ordered_parent_region_groups def.signature back_id + in + let backward_ids = List.append parents_ids [ back_id ] in + List.concat + (List.map + (fun id -> T.RegionGroupId.Map.find id ctx.backward_inputs) + backward_ids) + in + let inputs = + List.concat [ ctx.forward_inputs; input_state; backward_inputs ] + in + let inputs_lvs = + List.map (fun v -> mk_typed_pattern_from_var v None) inputs + in + (* Sanity check *) + log#ldebug + (lazy + ("SymbolicToPure.translate_fun_decl:" ^ "\n- forward_inputs: " + ^ String.concat ", " (List.map show_var ctx.forward_inputs) + ^ "\n- input_state: " + ^ String.concat ", " (List.map show_var input_state) + ^ "\n- backward_inputs: " + ^ String.concat ", " (List.map show_var backward_inputs) + ^ "\n- signature.inputs: " + ^ String.concat ", " (List.map show_ty signature.inputs))); + assert ( + List.for_all + (fun (var, ty) -> (var : var).ty = ty) + (List.combine inputs signature.inputs)); + Some { inputs; inputs_lvs; body } + in + (* Assemble the declaration *) + let def = + { + def_id; + back_id = bid; + basename; + signature; + is_global_decl_body = def.is_global_decl_body; + body; + } + in + (* Debugging *) + log#ldebug + (lazy + ("SymbolicToPure.translate_fun_decl: translated:\n" + ^ fun_decl_to_string ctx def)); + (* return *) + def + +let translate_type_decls (type_decls : T.type_decl list) : type_decl list = + List.map translate_type_decl type_decls + +(** Translates function signatures. + + Takes as input a list of function information containing: + - the function id + - a list of optional names for the inputs + - the function signature + + Returns a map from forward/backward functions identifiers to: + - translated function signatures + - optional names for the outputs values (we derive them for the backward + functions) + *) +let translate_fun_signatures (fun_infos : FA.fun_info A.FunDeclId.Map.t) + (types_infos : TA.type_infos) + (functions : (A.fun_id * string option list * A.fun_sig) list) : + fun_sig_named_outputs RegularFunIdMap.t = + (* For every function, translate the signatures of: + - the forward function + - the backward functions + *) + let translate_one (fun_id : A.fun_id) (input_names : string option list) + (sg : A.fun_sig) : (regular_fun_id * fun_sig_named_outputs) list = + (* The forward function *) + let fwd_sg = + translate_fun_sig fun_infos fun_id types_infos sg input_names None + in + let fwd_id = (fun_id, None) in + (* The backward functions *) + let back_sgs = + List.map + (fun (rg : T.region_var_group) -> + let tsg = + translate_fun_sig fun_infos fun_id types_infos sg input_names + (Some rg.id) + in + let id = (fun_id, Some rg.id) in + (id, tsg)) + sg.regions_hierarchy + in + (* Return *) + (fwd_id, fwd_sg) :: back_sgs + in + let translated = + List.concat + (List.map (fun (id, names, sg) -> translate_one id names sg) functions) + in + List.fold_left + (fun m (id, sg) -> RegularFunIdMap.add id sg m) + RegularFunIdMap.empty translated diff --git a/compiler/SynthesizeSymbolic.ml b/compiler/SynthesizeSymbolic.ml new file mode 100644 index 00000000..a2256bdd --- /dev/null +++ b/compiler/SynthesizeSymbolic.ml @@ -0,0 +1,156 @@ +module C = Collections +module T = Types +module V = Values +module E = Expressions +module A = LlbcAst +open SymbolicAst + +let mk_mplace (p : E.place) (ctx : Contexts.eval_ctx) : mplace = + let bv = Contexts.ctx_lookup_binder ctx p.var_id in + { bv; projection = p.projection } + +let mk_opt_mplace (p : E.place option) (ctx : Contexts.eval_ctx) : mplace option + = + match p with None -> None | Some p -> Some (mk_mplace p ctx) + +let mk_opt_place_from_op (op : E.operand) (ctx : Contexts.eval_ctx) : + mplace option = + match op with + | E.Copy p | E.Move p -> Some (mk_mplace p ctx) + | E.Constant _ -> None + +let synthesize_symbolic_expansion (sv : V.symbolic_value) + (place : mplace option) (seel : V.symbolic_expansion option list) + (exprl : expression list option) : expression option = + match exprl with + | None -> None + | Some exprl -> + let ls = List.combine seel exprl in + (* Match on the symbolic value type to know which can of expansion happened *) + let expansion = + match sv.V.sv_ty with + | T.Bool -> ( + (* Boolean expansion: there should be two branches *) + match ls with + | [ + (Some (V.SeConcrete (V.Bool true)), true_exp); + (Some (V.SeConcrete (V.Bool false)), false_exp); + ] -> + ExpandBool (true_exp, false_exp) + | _ -> failwith "Ill-formed boolean expansion") + | T.Integer int_ty -> + (* Switch over an integer: split between the "regular" branches + and the "otherwise" branch (which should be the last branch) *) + let branches, otherwise = C.List.pop_last ls in + (* For all the regular branches, the symbolic value should have + * been expanded to a constant *) + let get_scalar (see : V.symbolic_expansion option) : V.scalar_value + = + match see with + | Some (V.SeConcrete (V.Scalar cv)) -> + assert (cv.V.int_ty = int_ty); + cv + | _ -> failwith "Unreachable" + in + let branches = + List.map (fun (see, exp) -> (get_scalar see, exp)) branches + in + (* For the otherwise branch, the symbolic value should have been left + * unchanged *) + let otherwise_see, otherwise = otherwise in + assert (otherwise_see = None); + (* Return *) + ExpandInt (int_ty, branches, otherwise) + | T.Adt (_, _, _) -> + (* Branching: it is necessarily an enumeration expansion *) + let get_variant (see : V.symbolic_expansion option) : + T.VariantId.id option * V.symbolic_value list = + match see with + | Some (V.SeAdt (vid, fields)) -> (vid, fields) + | _ -> failwith "Ill-formed branching ADT expansion" + in + let exp = + List.map + (fun (see, exp) -> + let vid, fields = get_variant see in + (vid, fields, exp)) + ls + in + ExpandAdt exp + | T.Ref (_, _, _) -> ( + (* Reference expansion: there should be one branch *) + match ls with + | [ (Some see, exp) ] -> ExpandNoBranch (see, exp) + | _ -> failwith "Ill-formed borrow expansion") + | T.TypeVar _ | Char | Never | Str | Array _ | Slice _ -> + failwith "Ill-formed symbolic expansion" + in + Some (Expansion (place, sv, expansion)) + +let synthesize_symbolic_expansion_no_branching (sv : V.symbolic_value) + (place : mplace option) (see : V.symbolic_expansion) + (expr : expression option) : expression option = + let exprl = match expr with None -> None | Some expr -> Some [ expr ] in + synthesize_symbolic_expansion sv place [ Some see ] exprl + +let synthesize_function_call (call_id : call_id) + (abstractions : V.AbstractionId.id list) (type_params : T.ety list) + (args : V.typed_value list) (args_places : mplace option list) + (dest : V.symbolic_value) (dest_place : mplace option) + (expr : expression option) : expression option = + match expr with + | None -> None + | Some expr -> + let call = + { + call_id; + abstractions; + type_params; + args; + dest; + args_places; + dest_place; + } + in + Some (FunCall (call, expr)) + +let synthesize_global_eval (gid : A.GlobalDeclId.id) (dest : V.symbolic_value) + (expr : expression option) : expression option = + match expr with None -> None | Some e -> Some (EvalGlobal (gid, dest, e)) + +let synthesize_regular_function_call (fun_id : A.fun_id) + (call_id : V.FunCallId.id) (abstractions : V.AbstractionId.id list) + (type_params : T.ety list) (args : V.typed_value list) + (args_places : mplace option list) (dest : V.symbolic_value) + (dest_place : mplace option) (expr : expression option) : expression option + = + synthesize_function_call + (Fun (fun_id, call_id)) + abstractions type_params args args_places dest dest_place expr + +let synthesize_unary_op (unop : E.unop) (arg : V.typed_value) + (arg_place : mplace option) (dest : V.symbolic_value) + (dest_place : mplace option) (expr : expression option) : expression option + = + synthesize_function_call (Unop unop) [] [] [ arg ] [ arg_place ] dest + dest_place expr + +let synthesize_binary_op (binop : E.binop) (arg0 : V.typed_value) + (arg0_place : mplace option) (arg1 : V.typed_value) + (arg1_place : mplace option) (dest : V.symbolic_value) + (dest_place : mplace option) (expr : expression option) : expression option + = + synthesize_function_call (Binop binop) [] [] [ arg0; arg1 ] + [ arg0_place; arg1_place ] dest dest_place expr + +let synthesize_end_abstraction (abs : V.abs) (expr : expression option) : + expression option = + match expr with + | None -> None + | Some expr -> Some (EndAbstraction (abs, expr)) + +let synthesize_assignment (lplace : mplace) (rvalue : V.typed_value) + (rplace : mplace option) (expr : expression option) : expression option = + match expr with + | None -> None + | Some expr -> Some (Meta (Assignment (lplace, rvalue, rplace), expr)) diff --git a/compiler/Translate.ml b/compiler/Translate.ml new file mode 100644 index 00000000..8f3b94c4 --- /dev/null +++ b/compiler/Translate.ml @@ -0,0 +1,871 @@ +open InterpreterStatements +open Interpreter +module L = Logging +module T = Types +module A = LlbcAst +module SA = SymbolicAst +module Micro = PureMicroPasses +open PureUtils +open TranslateCore + +(** The local logger *) +let log = TranslateCore.log + +type config = { + eval_config : Contexts.partial_config; + mp_config : Micro.config; + use_state : bool; + (** Controls whether we need to use a state to model the external world + (I/O, for instance). + *) + split_files : bool; + (** Controls whether we split the generated definitions between different + files for the types, clauses and functions, or if we group them in + one file. + *) + test_unit_functions : bool; + (** If true, insert tests in the generated files to check that the + unit functions normalize to [Success _]. + + For instance, in F* it generates code like this: + {[ + let _ = assert_norm (FUNCTION () = Success ()) + ]} + *) + extract_decreases_clauses : bool; + (** If [true], insert [decreases] clauses for all the recursive definitions. + + The body of such clauses must be defined by the user. + *) + extract_template_decreases_clauses : bool; + (** In order to help the user, we can generate "template" decrease clauses + (i.e., definitions with proper signatures but dummy bodies) in a + dedicated file. + *) +} + +(** The result of running the symbolic interpreter on a function: + - the list of symbolic values used for the input values + - the generated symbolic AST +*) +type symbolic_fun_translation = V.symbolic_value list * SA.expression + +(** Execute the symbolic interpreter on a function to generate a list of symbolic ASTs, + for the forward function and the backward functions. +*) +let translate_function_to_symbolics (config : C.partial_config) + (trans_ctx : trans_ctx) (fdef : A.fun_decl) : + (symbolic_fun_translation * symbolic_fun_translation list) option = + (* Debug *) + log#ldebug + (lazy + ("translate_function_to_symbolics: " + ^ Print.fun_name_to_string fdef.A.name)); + + let { type_context; fun_context; global_context } = trans_ctx in + let fun_context = { C.fun_decls = fun_context.fun_decls } in + + match fdef.body with + | None -> None + | Some _ -> + (* Evaluate *) + let synthesize = true in + let evaluate gid = + let inputs, symb = + evaluate_function_symbolic config synthesize type_context fun_context + global_context fdef gid + in + (inputs, Option.get symb) + in + (* Execute the forward function *) + let forward = evaluate None in + (* Execute the backward functions *) + let backwards = + T.RegionGroupId.mapi + (fun gid _ -> evaluate (Some gid)) + fdef.signature.regions_hierarchy + in + + (* Return *) + Some (forward, backwards) + +(** Translate a function, by generating its forward and backward translations. + + [fun_sigs]: maps the forward/backward functions to their signatures. In case + of backward functions, we also provide names for the outputs. + TODO: maybe we should introduce a record for this. +*) +let translate_function_to_pure (config : C.partial_config) + (mp_config : Micro.config) (trans_ctx : trans_ctx) + (fun_sigs : SymbolicToPure.fun_sig_named_outputs RegularFunIdMap.t) + (pure_type_decls : Pure.type_decl Pure.TypeDeclId.Map.t) (fdef : A.fun_decl) + : pure_fun_translation = + (* Debug *) + log#ldebug + (lazy + ("translate_function_to_pure: " ^ Print.fun_name_to_string fdef.A.name)); + + let { type_context; fun_context; global_context } = trans_ctx in + let def_id = fdef.def_id in + + (* Compute the symbolic ASTs, if the function is transparent *) + let symbolic_trans = translate_function_to_symbolics config trans_ctx fdef in + let symbolic_forward, symbolic_backwards = + match symbolic_trans with + | None -> (None, None) + | Some (fwd, backs) -> (Some fwd, Some backs) + in + + (* Convert the symbolic ASTs to pure ASTs: *) + + (* Initialize the context *) + let forward_sig = RegularFunIdMap.find (A.Regular def_id, None) fun_sigs in + let sv_to_var = V.SymbolicValueId.Map.empty in + let var_counter = Pure.VarId.generator_zero in + let state_var, var_counter = Pure.VarId.fresh var_counter in + let calls = V.FunCallId.Map.empty in + let abstractions = V.AbstractionId.Map.empty in + let type_context = + { + SymbolicToPure.types_infos = type_context.type_infos; + llbc_type_decls = type_context.type_decls; + type_decls = pure_type_decls; + } + in + let fun_context = + { + SymbolicToPure.llbc_fun_decls = fun_context.fun_decls; + fun_sigs; + fun_infos = fun_context.fun_infos; + } + in + let global_context = + { SymbolicToPure.llbc_global_decls = global_context.global_decls } + in + let ctx = + { + SymbolicToPure.bid = None; + (* Dummy for now *) + sg = forward_sig.sg; + (* Will need to be updated for the backward functions *) + sv_to_var; + var_counter; + state_var; + type_context; + fun_context; + global_context; + fun_decl = fdef; + forward_inputs = []; + (* Empty for now *) + backward_inputs = T.RegionGroupId.Map.empty; + (* Empty for now *) + backward_outputs = T.RegionGroupId.Map.empty; + (* Empty for now *) + calls; + abstractions; + } + in + + (* We need to initialize the input/output variables *) + let num_forward_inputs = List.length fdef.signature.inputs in + let add_forward_inputs input_svs ctx = + match fdef.body with + | None -> ctx + | Some body -> + let forward_input_vars = LlbcAstUtils.fun_body_get_input_vars body in + let forward_input_varnames = + List.map (fun (v : A.var) -> v.name) forward_input_vars + in + let input_svs = List.combine forward_input_varnames input_svs in + let ctx, forward_inputs = + SymbolicToPure.fresh_named_vars_for_symbolic_values input_svs ctx + in + { ctx with forward_inputs } + in + + (* The symbolic to pure config *) + let sp_config = + { + SymbolicToPure.filter_useless_back_calls = + mp_config.filter_useless_monadic_calls; + } + in + + (* Translate the forward function *) + let pure_forward = + match symbolic_forward with + | None -> SymbolicToPure.translate_fun_decl sp_config ctx None + | Some (fwd_svs, fwd_ast) -> + SymbolicToPure.translate_fun_decl sp_config + (add_forward_inputs fwd_svs ctx) + (Some fwd_ast) + in + + (* Translate the backward functions *) + let translate_backward (rg : T.region_var_group) : Pure.fun_decl = + (* For the backward inputs/outputs initialization: we use the fact that + * there are no nested borrows for now, and so that the region groups + * can't have parents *) + assert (rg.parents = []); + let back_id = rg.id in + + match symbolic_backwards with + | None -> + (* Initialize the context - note that the ret_ty is not really + * useful as we don't translate a body *) + let backward_sg = + RegularFunIdMap.find (A.Regular def_id, Some back_id) fun_sigs + in + let ctx = { ctx with bid = Some back_id; sg = backward_sg.sg } in + + (* Translate *) + SymbolicToPure.translate_fun_decl sp_config ctx None + | Some symbolic_backwards -> + let input_svs, symbolic = + T.RegionGroupId.nth symbolic_backwards back_id + in + let ctx = add_forward_inputs input_svs ctx in + (* TODO: the computation of the backward inputs is a bit awckward... *) + let backward_sg = + RegularFunIdMap.find (A.Regular def_id, Some back_id) fun_sigs + in + (* We need to ignore the forward inputs, and the state input (if there is) *) + let fun_info = + SymbolicToPure.get_fun_effect_info fun_context.fun_infos + (A.Regular def_id) (Some back_id) + in + let _, backward_inputs = + Collections.List.split_at backward_sg.sg.inputs + (num_forward_inputs + if fun_info.input_state then 1 else 0) + in + (* As we forbid nested borrows, the additional inputs for the backward + * functions come from the borrows in the return value of the rust function: + * we thus use the name "ret" for those inputs *) + let backward_inputs = + List.map (fun ty -> (Some "ret", ty)) backward_inputs + in + let ctx, backward_inputs = + SymbolicToPure.fresh_vars backward_inputs ctx + in + (* The outputs for the backward functions, however, come from borrows + * present in the input values of the rust function: for those we reuse + * the names of the input values. *) + let backward_outputs = + List.combine backward_sg.output_names backward_sg.sg.doutputs + in + let ctx, backward_outputs = + SymbolicToPure.fresh_vars backward_outputs ctx + in + let backward_inputs = + T.RegionGroupId.Map.singleton back_id backward_inputs + in + let backward_outputs = + T.RegionGroupId.Map.singleton back_id backward_outputs + in + + (* Put everything in the context *) + let ctx = + { + ctx with + bid = Some back_id; + sg = backward_sg.sg; + backward_inputs; + backward_outputs; + } + in + + (* Translate *) + SymbolicToPure.translate_fun_decl sp_config ctx (Some symbolic) + in + let pure_backwards = + List.map translate_backward fdef.signature.regions_hierarchy + in + + (* Return *) + (pure_forward, pure_backwards) + +let translate_module_to_pure (config : C.partial_config) + (mp_config : Micro.config) (use_state : bool) (crate : Crates.llbc_crate) : + trans_ctx * Pure.type_decl list * (bool * pure_fun_translation) list = + (* Debug *) + log#ldebug (lazy "translate_module_to_pure"); + + (* Compute the type and function contexts *) + let type_context, fun_context, global_context = + compute_type_fun_global_contexts crate + in + let fun_infos = + FA.analyze_module crate fun_context.C.fun_decls + global_context.C.global_decls use_state + in + let fun_context = { fun_decls = fun_context.fun_decls; fun_infos } in + let trans_ctx = { type_context; fun_context; global_context } in + + (* Translate all the type definitions *) + let type_decls = SymbolicToPure.translate_type_decls crate.types in + + (* Compute the type definition map *) + let type_decls_map = + Pure.TypeDeclId.Map.of_list + (List.map (fun (def : Pure.type_decl) -> (def.def_id, def)) type_decls) + in + + (* Translate all the function *signatures* *) + let assumed_sigs = + List.map + (fun (id, sg, _, _) -> + (A.Assumed id, List.map (fun _ -> None) (sg : A.fun_sig).inputs, sg)) + Assumed.assumed_infos + in + let local_sigs = + List.map + (fun (fdef : A.fun_decl) -> + let input_names = + match fdef.body with + | None -> List.map (fun _ -> None) fdef.signature.inputs + | Some body -> + List.map + (fun (v : A.var) -> v.name) + (LlbcAstUtils.fun_body_get_input_vars body) + in + (A.Regular fdef.def_id, input_names, fdef.signature)) + crate.functions + in + let sigs = List.append assumed_sigs local_sigs in + let fun_sigs = + SymbolicToPure.translate_fun_signatures fun_context.fun_infos + type_context.type_infos sigs + in + + (* Translate all the *transparent* functions *) + let pure_translations = + List.map + (translate_function_to_pure config mp_config trans_ctx fun_sigs + type_decls_map) + crate.functions + in + + (* Apply the micro-passes *) + let pure_translations = + List.map + (Micro.apply_passes_to_pure_fun_translation mp_config trans_ctx) + pure_translations + in + + (* Return *) + (trans_ctx, type_decls, pure_translations) + +(** Extraction context *) +type gen_ctx = { + crate : Crates.llbc_crate; + extract_ctx : PureToExtract.extraction_ctx; + trans_types : Pure.type_decl Pure.TypeDeclId.Map.t; + trans_funs : (bool * pure_fun_translation) A.FunDeclId.Map.t; + functions_with_decreases_clause : A.FunDeclId.Set.t; +} + +type gen_config = { + mp_config : Micro.config; + use_state : bool; + extract_types : bool; + extract_decreases_clauses : bool; + extract_template_decreases_clauses : bool; + extract_fun_decls : bool; + extract_transparent : bool; + (** If [true], extract the transparent declarations, otherwise ignore. *) + extract_opaque : bool; + (** If [true], extract the opaque declarations, otherwise ignore. *) + extract_state_type : bool; + (** If [true], generate a definition/declaration for the state type *) + interface : bool; + (** [true] if we generate an interface file, [false] otherwise. + For now, this only impacts whether we use [val] or [assume val] for the + opaque definitions. In the future, we might want to extract all the + declarations in an interface file, together with an implementation file + if needed. + *) + test_unit_functions : bool; +} + +(** Returns the pair: (has opaque type decls, has opaque fun decls) *) +let module_has_opaque_decls (ctx : gen_ctx) : bool * bool = + let has_opaque_types = + Pure.TypeDeclId.Map.exists + (fun _ (d : Pure.type_decl) -> + match d.kind with Opaque -> true | _ -> false) + ctx.trans_types + in + let has_opaque_funs = + A.FunDeclId.Map.exists + (fun _ ((_, (t_fwd, _)) : bool * pure_fun_translation) -> + Option.is_none t_fwd.body) + ctx.trans_funs + in + (has_opaque_types, has_opaque_funs) + +(** A generic utility to generate the extracted definitions: as we may want to + split the definitions between different files (or not), we can control + what is precisely extracted. + *) +let extract_definitions (fmt : Format.formatter) (config : gen_config) + (ctx : gen_ctx) : unit = + (* Export the definition groups to the file, in the proper order *) + let export_type (qualif : ExtractToFStar.type_decl_qualif) + (id : Pure.TypeDeclId.id) : unit = + (* Retrive the declaration *) + let def = Pure.TypeDeclId.Map.find id ctx.trans_types in + (* Update the qualifier, if the type is opaque *) + let is_opaque, qualif = + match def.kind with + | Enum _ | Struct _ -> (false, qualif) + | Opaque -> + let qualif = + if config.interface then ExtractToFStar.TypeVal + else ExtractToFStar.AssumeType + in + (true, qualif) + in + (* Extract, if the config instructs to do so (depending on whether the type + * is opaque or not) *) + if + (is_opaque && config.extract_opaque) + || ((not is_opaque) && config.extract_transparent) + then ExtractToFStar.extract_type_decl ctx.extract_ctx fmt qualif def + in + + (* Utility to check a function has a decrease clause *) + let has_decreases_clause (def : Pure.fun_decl) : bool = + A.FunDeclId.Set.mem def.def_id ctx.functions_with_decreases_clause + in + + (* In case of (non-mutually) recursive functions, we use a simple procedure to + * check if the forward and backward functions are mutually recursive. + *) + let export_functions (is_rec : bool) + (pure_ls : (bool * pure_fun_translation) list) : unit = + (* Concatenate the function definitions, filtering the useless forward + * functions. We also make pairs: (forward function, backward function) + * (the forward function contains useful information that we want to keep) *) + let fls = + List.concat + (List.map + (fun (keep_fwd, (fwd, back_ls)) -> + let back_ls = List.map (fun back -> (fwd, back)) back_ls in + if keep_fwd then (fwd, fwd) :: back_ls else back_ls) + pure_ls) + in + (* Extract the decrease clauses template bodies *) + if config.extract_template_decreases_clauses then + List.iter + (fun (_, (fwd, _)) -> + let has_decr_clause = has_decreases_clause fwd in + if has_decr_clause then + ExtractToFStar.extract_template_decreases_clause ctx.extract_ctx fmt + fwd) + pure_ls; + (* Extract the function definitions *) + (if config.extract_fun_decls then + (* Check if the functions are mutually recursive - this really works + * to check if the forward and backward translations of a single + * recursive function are mutually recursive *) + let is_mut_rec = + if is_rec then + if List.length pure_ls <= 1 then + not (PureUtils.functions_not_mutually_recursive (List.map fst fls)) + else true + else false + in + List.iteri + (fun i (fwd_def, def) -> + let is_opaque = Option.is_none fwd_def.Pure.body in + let qualif = + if is_opaque then + if config.interface then ExtractToFStar.Val + else ExtractToFStar.AssumeVal + else if not is_rec then ExtractToFStar.Let + else if is_mut_rec then + if i = 0 then ExtractToFStar.LetRec else ExtractToFStar.And + else ExtractToFStar.LetRec + in + let has_decr_clause = + has_decreases_clause def && config.extract_decreases_clauses + in + (* Check if the definition needs to be filtered or not *) + if + ((not is_opaque) && config.extract_transparent) + || (is_opaque && config.extract_opaque) + then + ExtractToFStar.extract_fun_decl ctx.extract_ctx fmt qualif + has_decr_clause def) + fls); + (* Insert unit tests if necessary *) + if config.test_unit_functions then + List.iter + (fun (keep_fwd, (fwd, _)) -> + if keep_fwd then + ExtractToFStar.extract_unit_test_if_unit_fun ctx.extract_ctx fmt fwd) + pure_ls + in + + (* TODO: Check correct behaviour with opaque globals *) + let export_global (id : A.GlobalDeclId.id) : unit = + let global_decls = ctx.extract_ctx.trans_ctx.global_context.global_decls in + let global = A.GlobalDeclId.Map.find id global_decls in + let _, (body, body_backs) = + A.FunDeclId.Map.find global.body_id ctx.trans_funs + in + assert (List.length body_backs = 0); + + let is_opaque = Option.is_none body.Pure.body in + if + ((not is_opaque) && config.extract_transparent) + || (is_opaque && config.extract_opaque) + then + ExtractToFStar.extract_global_decl ctx.extract_ctx fmt global body + config.interface + in + + let export_state_type () : unit = + let qualif = + if config.interface then ExtractToFStar.TypeVal + else ExtractToFStar.AssumeType + in + ExtractToFStar.extract_state_type fmt ctx.extract_ctx qualif + in + + let export_decl (decl : Crates.declaration_group) : unit = + match decl with + | Type (NonRec id) -> + if config.extract_types then export_type ExtractToFStar.Type id + | Type (Rec ids) -> + (* Rk.: we shouldn't have (mutually) recursive opaque types *) + if config.extract_types then + List.iteri + (fun i id -> + let qualif = + if i = 0 then ExtractToFStar.Type else ExtractToFStar.And + in + export_type qualif id) + ids + | Fun (NonRec id) -> + (* Lookup *) + let pure_fun = A.FunDeclId.Map.find id ctx.trans_funs in + (* Translate *) + export_functions false [ pure_fun ] + | Fun (Rec ids) -> + (* General case of mutually recursive functions *) + (* Lookup *) + let pure_funs = + List.map (fun id -> A.FunDeclId.Map.find id ctx.trans_funs) ids + in + (* Translate *) + export_functions true pure_funs + | Global id -> export_global id + in + + (* If we need to export the state type: we try to export it after we defined + * the type definitions, because if the user wants to define a model for the + * type, he might want to reuse them in the state type. + * More specifically: if we extract functions, we have no choice but to define + * the state type before the functions, because they may reuse this state + * type: in this case, we define/declare it at the very beginning. Otherwise, + * we define/declare it at the very end. + *) + if config.extract_state_type && config.extract_fun_decls then + export_state_type (); + List.iter export_decl ctx.crate.declarations; + if config.extract_state_type && not config.extract_fun_decls then + export_state_type () + +let extract_file (config : gen_config) (ctx : gen_ctx) (filename : string) + (rust_module_name : string) (module_name : string) (custom_msg : string) + (custom_imports : string list) (custom_includes : string list) : unit = + (* Open the file and create the formatter *) + let out = open_out filename in + let fmt = Format.formatter_of_out_channel out in + + (* Print the headers. + * Note that we don't use the OCaml formatter for purpose: we want to control + * line insertion (we have to make sure that some instructions like [open MODULE] + * are printed on one line!). + * This is ok as long as we end up with a line break, so that the formatter's + * internal count is consistent with the state of the file. + *) + (* Create the header *) + Printf.fprintf out "(** THIS FILE WAS AUTOMATICALLY GENERATED BY AENEAS *)\n"; + Printf.fprintf out "(** [%s]%s *)\n" rust_module_name custom_msg; + Printf.fprintf out "module %s\n" module_name; + Printf.fprintf out "open Primitives\n"; + (* Add the custom imports *) + List.iter (fun m -> Printf.fprintf out "open %s\n" m) custom_imports; + (* Add the custom includes *) + List.iter (fun m -> Printf.fprintf out "include %s\n" m) custom_includes; + (* Z3 options - note that we use fuel 1 because it its useful for the decrease clauses *) + Printf.fprintf out "\n#set-options \"--z3rlimit 50 --fuel 1 --ifuel 1\"\n"; + + (* From now onwards, we use the formatter *) + (* Set the margin *) + Format.pp_set_margin fmt 80; + + (* Create a vertical box *) + Format.pp_open_vbox fmt 0; + + (* Extract the definitions *) + extract_definitions fmt config ctx; + + (* Close the box and end the formatting *) + Format.pp_close_box fmt (); + Format.pp_print_newline fmt (); + + (* Some logging *) + log#linfo (lazy ("Generated: " ^ filename)); + + (* Flush and close the file *) + close_out out + +(** Translate a module and write the synthesized code to an output file. + TODO: rename to translate_crate + *) +let translate_module (filename : string) (dest_dir : string) (config : config) + (crate : Crates.llbc_crate) : unit = + (* Translate the module to the pure AST *) + let trans_ctx, trans_types, trans_funs = + translate_module_to_pure config.eval_config config.mp_config + config.use_state crate + in + + (* Initialize the extraction context - for now we extract only to F* *) + let names_map = + PureToExtract.initialize_names_map ExtractToFStar.fstar_names_map_init + in + let variant_concatenate_type_name = true in + let fstar_fmt = + ExtractToFStar.mk_formatter trans_ctx crate.name + variant_concatenate_type_name + in + let ctx = + { PureToExtract.trans_ctx; names_map; fmt = fstar_fmt; indent_incr = 2 } + in + + (* We need to compute which functions are recursive, in order to know + * whether we should generate a decrease clause or not. *) + let rec_functions = + A.FunDeclId.Set.of_list + (List.concat + (List.map + (fun decl -> + match decl with Crates.Fun (Rec ids) -> ids | _ -> []) + crate.declarations)) + in + + (* Register unique names for all the top-level types, globals and functions. + * Note that the order in which we generate the names doesn't matter: + * we just need to generate a mapping from identifier to name, and make + * sure there are no name clashes. *) + let ctx = + List.fold_left + (fun ctx def -> ExtractToFStar.extract_type_decl_register_names ctx def) + ctx trans_types + in + + let ctx = + List.fold_left + (fun ctx (keep_fwd, def) -> + (* We generate a decrease clause for all the recursive functions *) + let gen_decr_clause = + A.FunDeclId.Set.mem (fst def).Pure.def_id rec_functions + in + (* Register the names, only if the function is not a global body - + * those are handled later *) + let is_global = (fst def).Pure.is_global_decl_body in + if is_global then ctx + else + ExtractToFStar.extract_fun_decl_register_names ctx keep_fwd + gen_decr_clause def) + ctx trans_funs + in + + let ctx = + List.fold_left ExtractToFStar.extract_global_decl_register_names ctx + crate.globals + in + + (* Open the output file *) + (* First compute the filename by replacing the extension and converting the + * case (rust module names are snake case) *) + let module_name, extract_filebasename = + match Filename.chop_suffix_opt ~suffix:".llbc" filename with + | None -> + (* Note that we already checked the suffix upon opening the file *) + failwith "Unreachable" + | Some filename -> + (* Retrieve the file basename *) + let basename = Filename.basename filename in + (* Convert the case *) + let module_name = StringUtils.to_camel_case basename in + (* Concatenate *) + (module_name, Filename.concat dest_dir module_name) + in + + (* Put the translated definitions in maps *) + let trans_types = + Pure.TypeDeclId.Map.of_list + (List.map (fun (d : Pure.type_decl) -> (d.def_id, d)) trans_types) + in + let trans_funs = + A.FunDeclId.Map.of_list + (List.map + (fun ((keep_fwd, (fd, bdl)) : bool * pure_fun_translation) -> + (fd.def_id, (keep_fwd, (fd, bdl)))) + trans_funs) + in + + (* Create the directory, if necessary *) + if not (Sys.file_exists dest_dir) then ( + log#linfo (lazy ("Creating missing directory: " ^ dest_dir)); + (* Create a directory with *default* permissions *) + Core_unix.mkdir_p dest_dir); + + (* Copy "Primitives.fst" - I couldn't find a "cp" function in the OCaml + * libraries... *) + let _ = + let src = open_in "fstar/Primitives.fst" in + let tgt_filename = Filename.concat dest_dir "Primitives.fst" in + let tgt = open_out tgt_filename in + try + while true do + (* We copy line by line *) + let line = input_line src in + Printf.fprintf tgt "%s\n" line + done + with End_of_file -> + close_in src; + close_out tgt; + log#linfo (lazy ("Copied: " ^ tgt_filename)) + in + + (* Extract the file(s) *) + let gen_ctx = + { + crate; + extract_ctx = ctx; + trans_types; + trans_funs; + functions_with_decreases_clause = rec_functions; + } + in + + let use_state = config.use_state in + + (* Extract one or several files, depending on the configuration *) + if config.split_files then ( + let base_gen_config = + { + mp_config = config.mp_config; + use_state; + extract_types = false; + extract_decreases_clauses = config.extract_decreases_clauses; + extract_template_decreases_clauses = false; + extract_fun_decls = false; + extract_transparent = true; + extract_opaque = false; + extract_state_type = false; + interface = false; + test_unit_functions = false; + } + in + + (* Check if there are opaque types and functions - in which case we need + * to split *) + let has_opaque_types, has_opaque_funs = module_has_opaque_decls gen_ctx in + let has_opaque_types = has_opaque_types || use_state in + + (* Extract the types *) + (* If there are opaque types, we extract in an interface *) + let types_filename_ext = if has_opaque_types then ".fsti" else ".fst" in + let types_filename = extract_filebasename ^ ".Types" ^ types_filename_ext in + let types_module = module_name ^ ".Types" in + let types_config = + { + base_gen_config with + extract_types = true; + extract_opaque = true; + extract_state_type = use_state; + interface = has_opaque_types; + } + in + extract_file types_config gen_ctx types_filename crate.Crates.name + types_module ": type definitions" [] []; + + (* Extract the template clauses *) + let needs_clauses_module = + config.extract_decreases_clauses + && not (A.FunDeclId.Set.is_empty rec_functions) + in + (if needs_clauses_module && config.extract_template_decreases_clauses then + let clauses_filename = extract_filebasename ^ ".Clauses.Template.fst" in + let clauses_module = module_name ^ ".Clauses.Template" in + let clauses_config = + { base_gen_config with extract_template_decreases_clauses = true } + in + extract_file clauses_config gen_ctx clauses_filename crate.Crates.name + clauses_module ": templates for the decreases clauses" [ types_module ] + []); + + (* Extract the opaque functions, if needed *) + let opaque_funs_module = + if has_opaque_funs then ( + let opaque_filename = extract_filebasename ^ ".Opaque.fsti" in + let opaque_module = module_name ^ ".Opaque" in + let opaque_config = + { + base_gen_config with + extract_fun_decls = true; + extract_transparent = false; + extract_opaque = true; + interface = true; + } + in + extract_file opaque_config gen_ctx opaque_filename crate.Crates.name + opaque_module ": opaque function definitions" [] [ types_module ]; + [ opaque_module ]) + else [] + in + + (* Extract the functions *) + let fun_filename = extract_filebasename ^ ".Funs.fst" in + let fun_module = module_name ^ ".Funs" in + let fun_config = + { + base_gen_config with + extract_fun_decls = true; + test_unit_functions = config.test_unit_functions; + } + in + let clauses_module = + if needs_clauses_module then [ module_name ^ ".Clauses" ] else [] + in + extract_file fun_config gen_ctx fun_filename crate.Crates.name fun_module + ": function definitions" [] + ([ types_module ] @ opaque_funs_module @ clauses_module)) + else + let gen_config = + { + mp_config = config.mp_config; + use_state; + extract_types = true; + extract_decreases_clauses = config.extract_decreases_clauses; + extract_template_decreases_clauses = + config.extract_template_decreases_clauses; + extract_fun_decls = true; + extract_transparent = true; + extract_opaque = true; + extract_state_type = use_state; + interface = false; + test_unit_functions = config.test_unit_functions; + } + in + (* Add the extension for F* *) + let extract_filename = extract_filebasename ^ ".fst" in + extract_file gen_config gen_ctx extract_filename crate.Crates.name + module_name "" [] [] diff --git a/compiler/TranslateCore.ml b/compiler/TranslateCore.ml new file mode 100644 index 00000000..a658147d --- /dev/null +++ b/compiler/TranslateCore.ml @@ -0,0 +1,65 @@ +(** Some utilities for the translation *) + +open InterpreterStatements +module L = Logging +module T = Types +module A = LlbcAst +module SA = SymbolicAst +module FA = FunsAnalysis + +(** The local logger *) +let log = L.translate_log + +type type_context = C.type_context [@@deriving show] + +type fun_context = { + fun_decls : A.fun_decl A.FunDeclId.Map.t; + fun_infos : FA.fun_info A.FunDeclId.Map.t; +} +[@@deriving show] + +type global_context = C.global_context [@@deriving show] + +type trans_ctx = { + type_context : type_context; + fun_context : fun_context; + global_context : global_context; +} + +type pure_fun_translation = Pure.fun_decl * Pure.fun_decl list + +let type_decl_to_string (ctx : trans_ctx) (def : Pure.type_decl) : string = + let type_params = def.type_params in + let type_decls = ctx.type_context.type_decls in + let fmt = PrintPure.mk_type_formatter type_decls type_params in + PrintPure.type_decl_to_string fmt def + +let type_id_to_string (ctx : trans_ctx) (def : Pure.type_decl) : string = + let type_params = def.type_params in + let type_decls = ctx.type_context.type_decls in + let fmt = PrintPure.mk_type_formatter type_decls type_params in + PrintPure.type_decl_to_string fmt def + +let fun_sig_to_string (ctx : trans_ctx) (sg : Pure.fun_sig) : string = + let type_params = sg.type_params in + let type_decls = ctx.type_context.type_decls in + let fun_decls = ctx.fun_context.fun_decls in + let global_decls = ctx.global_context.global_decls in + let fmt = + PrintPure.mk_ast_formatter type_decls fun_decls global_decls type_params + in + PrintPure.fun_sig_to_string fmt sg + +let fun_decl_to_string (ctx : trans_ctx) (def : Pure.fun_decl) : string = + let type_params = def.signature.type_params in + let type_decls = ctx.type_context.type_decls in + let fun_decls = ctx.fun_context.fun_decls in + let global_decls = ctx.global_context.global_decls in + let fmt = + PrintPure.mk_ast_formatter type_decls fun_decls global_decls type_params + in + PrintPure.fun_decl_to_string fmt def + +let fun_decl_id_to_string (ctx : trans_ctx) (id : A.FunDeclId.id) : string = + Print.fun_name_to_string + (A.FunDeclId.Map.find id ctx.fun_context.fun_decls).name diff --git a/compiler/Types.ml b/compiler/Types.ml new file mode 100644 index 00000000..326ef76f --- /dev/null +++ b/compiler/Types.ml @@ -0,0 +1,208 @@ +open Identifiers +open Names +open Meta +module TypeVarId = IdGen () +module TypeDeclId = IdGen () +module VariantId = IdGen () +module FieldId = IdGen () + +(** Region variable ids. Used in function signatures. *) +module RegionVarId = IdGen () + +(** Region ids. Used for symbolic executions. *) +module RegionId = IdGen () + +module RegionGroupId = IdGen () + +type ('id, 'name) indexed_var = { + index : 'id; (** Unique index identifying the variable *) + name : 'name; (** Variable name *) +} +[@@deriving show] + +type type_var = (TypeVarId.id, string) indexed_var [@@deriving show] +type region_var = (RegionVarId.id, string option) indexed_var [@@deriving show] + +(** A region. + + Regions are used in function signatures (in which case we use region variable + ids) and in symbolic variables and projections (in which case we use region + ids). + *) +type 'rid region = + | Static (** Static region *) + | Var of 'rid (** Non-static region *) +[@@deriving show, ord] + +(** The type of erased regions. + + We could use unit, but having a dedicated type makes things more explicit. + *) +type erased_region = Erased [@@deriving show, ord] + +(** A group of regions. + + Results from a lifetime analysis: we group the regions with the same + lifetime together, and compute the hierarchy between the regions. + This is necessary to introduce the proper abstraction with the + proper constraints, when evaluating a function call in symbolic mode. +*) +type ('id, 'r) g_region_group = { + id : 'id; + regions : 'r list; + parents : 'id list; +} +[@@deriving show] + +type ('r, 'id) g_region_groups = ('r, 'id) g_region_group list [@@deriving show] + +type region_var_group = (RegionGroupId.id, RegionVarId.id) g_region_group +[@@deriving show] + +type region_var_groups = (RegionGroupId.id, RegionVarId.id) g_region_groups +[@@deriving show] + +type integer_type = + | Isize + | I8 + | I16 + | I32 + | I64 + | I128 + | Usize + | U8 + | U16 + | U32 + | U64 + | U128 +[@@deriving show, ord] + +let all_signed_int_types = [ Isize; I8; I16; I32; I64; I128 ] +let all_unsigned_int_types = [ Usize; U8; U16; U32; U64; U128 ] +let all_int_types = List.append all_signed_int_types all_unsigned_int_types + +type ref_kind = Mut | Shared [@@deriving show, ord] +type assumed_ty = Box | Vec | Option [@@deriving show, ord] + +(** The variant id for [Option::None] *) +let option_none_id = VariantId.of_int 0 + +(** The variant id for [Option::Some] *) +let option_some_id = VariantId.of_int 1 + +(** Type identifier for ADTs. + + ADTs are very general in our encoding: they account for "regular" ADTs, + tuples and also assumed types. +*) +type type_id = AdtId of TypeDeclId.id | Tuple | Assumed of assumed_ty +[@@deriving show, ord] + +(** Ancestor for iter visitor for [ty] *) +class ['self] iter_ty_base = + object (_self : 'self) + inherit [_] VisitorsRuntime.iter + method visit_'r : 'env -> 'r -> unit = fun _ _ -> () + method visit_id : 'env -> TypeVarId.id -> unit = fun _ _ -> () + method visit_type_id : 'env -> type_id -> unit = fun _ _ -> () + method visit_integer_type : 'env -> integer_type -> unit = fun _ _ -> () + method visit_ref_kind : 'env -> ref_kind -> unit = fun _ _ -> () + end + +(** Ancestor for map visitor for [ty] *) +class ['self] map_ty_base = + object (_self : 'self) + inherit [_] VisitorsRuntime.map + method visit_'r : 'env -> 'r -> 'r = fun _ r -> r + method visit_id : 'env -> TypeVarId.id -> TypeVarId.id = fun _ id -> id + method visit_type_id : 'env -> type_id -> type_id = fun _ id -> id + + method visit_integer_type : 'env -> integer_type -> integer_type = + fun _ ity -> ity + + method visit_ref_kind : 'env -> ref_kind -> ref_kind = fun _ rk -> rk + end + +type 'r ty = + | Adt of type_id * 'r list * 'r ty list + (** {!Adt} encodes ADTs, tuples and assumed types *) + | TypeVar of TypeVarId.id + | Bool + | Char + | Never + | Integer of integer_type + | Str + | Array of 'r ty (* TODO: there should be a constant with the array *) + | Slice of 'r ty + | Ref of 'r * 'r ty * ref_kind +[@@deriving + show, + ord, + visitors + { + name = "iter_ty"; + variety = "iter"; + ancestors = [ "iter_ty_base" ]; + nude = true (* Don't inherit {!VisitorsRuntime.iter} *); + concrete = true; + polymorphic = false; + }, + visitors + { + name = "map_ty"; + variety = "map"; + ancestors = [ "map_ty_base" ]; + nude = true (* Don't inherit {!VisitorsRuntime.iter} *); + concrete = true; + polymorphic = false; + }] +(* TODO: group Bool, Char, etc. in Constant *) + +(** Generic type with regions *) +type 'r gr_ty = 'r region ty [@@deriving show, ord] + +(** *S*ignature types. + + Used in function signatures and type definitions. + *) +type sty = RegionVarId.id gr_ty [@@deriving show, ord] + +(** Type with *R*egions. + + Used to project borrows/loans inside of abstractions, during symbolic + execution. + *) +type rty = RegionId.id gr_ty [@@deriving show, ord] + +(** Type with *E*rased regions. + + Used in function bodies, "regular" value types, etc. + *) +type ety = erased_region ty [@@deriving show, ord] + +type field = { meta : meta; field_name : string option; field_ty : sty } +[@@deriving show] + +type variant = { meta : meta; variant_name : string; fields : field list } +[@@deriving show] + +type type_decl_kind = + | Struct of field list + | Enum of variant list + | Opaque + (** An opaque type: either a local type marked as opaque, or an external type *) +[@@deriving show] + +type type_decl = { + def_id : TypeDeclId.id; + meta : meta; + name : type_name; + region_params : region_var list; + type_params : type_var list; + kind : type_decl_kind; + regions_hierarchy : region_var_groups; + (** Stores the hierarchy between the regions (which regions have the + same lifetime, which lifetime should end before which other lifetime, + etc.) *) +} +[@@deriving show] diff --git a/compiler/TypesAnalysis.ml b/compiler/TypesAnalysis.ml new file mode 100644 index 00000000..60ce5149 --- /dev/null +++ b/compiler/TypesAnalysis.ml @@ -0,0 +1,328 @@ +open Types +open Crates + +type subtype_info = { + under_borrow : bool; (** Are we inside a borrow? *) + under_mut_borrow : bool; (** Are we inside a mut borrow? *) +} +[@@deriving show] + +(** See {!type_decl_info} *) +type type_param_info = subtype_info [@@deriving show] + +type expl_info = subtype_info [@@deriving show] + +type type_borrows_info = { + contains_static : bool; + (** Does the type (transitively) contains a static borrow? *) + contains_borrow : bool; + (** Does the type (transitively) contains a borrow? *) + contains_nested_borrows : bool; + (** Does the type (transitively) contains nested borrows? *) + contains_borrow_under_mut : bool; +} +[@@deriving show] + +(** Generic definition *) +type 'p g_type_info = { + borrows_info : type_borrows_info; + (** Various informations about the borrows *) + param_infos : 'p; (** Gives information about the type parameters *) +} +[@@deriving show] + +(** Information about a type definition. *) +type type_decl_info = type_param_info list g_type_info [@@deriving show] + +(** Information about a type. *) +type ty_info = type_borrows_info [@@deriving show] + +(** Helper definition. + + Allows us to factorize code: {!analyze_full_ty} is used both to analyze + type definitions and types. *) +type partial_type_info = type_param_info list option g_type_info +[@@deriving show] + +type type_infos = type_decl_info TypeDeclId.Map.t [@@deriving show] + +let expl_info_init = { under_borrow = false; under_mut_borrow = false } + +let type_borrows_info_init : type_borrows_info = + { + contains_static = false; + contains_borrow = false; + contains_nested_borrows = false; + contains_borrow_under_mut = false; + } + +let initialize_g_type_info (param_infos : 'p) : 'p g_type_info = + { borrows_info = type_borrows_info_init; param_infos } + +let initialize_type_decl_info (def : type_decl) : type_decl_info = + let param_info = { under_borrow = false; under_mut_borrow = false } in + let param_infos = List.map (fun _ -> param_info) def.type_params in + initialize_g_type_info param_infos + +let type_decl_info_to_partial_type_info (info : type_decl_info) : + partial_type_info = + { borrows_info = info.borrows_info; param_infos = Some info.param_infos } + +let partial_type_info_to_type_decl_info (info : partial_type_info) : + type_decl_info = + { + borrows_info = info.borrows_info; + param_infos = Option.get info.param_infos; + } + +let partial_type_info_to_ty_info (info : partial_type_info) : ty_info = + info.borrows_info + +let analyze_full_ty (r_is_static : 'r -> bool) (updated : bool ref) + (infos : type_infos) (ty_info : partial_type_info) (ty : 'r ty) : + partial_type_info = + (* Small utility *) + let check_update_bool (original : bool) (nv : bool) : bool = + if nv && not original then ( + updated := true; + nv) + else original + in + + (* Update a partial_type_info, while registering if we actually performed an update *) + let update_ty_info (ty_info : partial_type_info) + (ty_b_info : type_borrows_info) : partial_type_info = + let original = ty_info.borrows_info in + let contains_static = + check_update_bool original.contains_static ty_b_info.contains_static + in + let contains_borrow = + check_update_bool original.contains_borrow ty_b_info.contains_borrow + in + let contains_nested_borrows = + check_update_bool original.contains_nested_borrows + ty_b_info.contains_nested_borrows + in + let contains_borrow_under_mut = + check_update_bool original.contains_borrow_under_mut + ty_b_info.contains_borrow_under_mut + in + let updated_borrows_info = + { + contains_static; + contains_borrow; + contains_nested_borrows; + contains_borrow_under_mut; + } + in + { ty_info with borrows_info = updated_borrows_info } + in + + (* The recursive function which explores the type *) + let rec analyze (expl_info : expl_info) (ty_info : partial_type_info) + (ty : 'r ty) : partial_type_info = + match ty with + | Bool | Char | Never | Integer _ | Str -> ty_info + | TypeVar var_id -> ( + (* Update the information for the proper parameter, if necessary *) + match ty_info.param_infos with + | None -> ty_info + | Some param_infos -> + let param_info = TypeVarId.nth param_infos var_id in + (* Set [under_borrow] *) + let under_borrow = + check_update_bool param_info.under_borrow expl_info.under_borrow + in + (* Set [under_nested_borrows] *) + let under_mut_borrow = + check_update_bool param_info.under_mut_borrow + expl_info.under_mut_borrow + in + (* Update param_info *) + let param_info = { under_borrow; under_mut_borrow } in + let param_infos = + TypeVarId.update_nth param_infos var_id param_info + in + let param_infos = Some param_infos in + { ty_info with param_infos }) + | Array ty | Slice ty -> + (* Just dive in *) + analyze expl_info ty_info ty + | Ref (r, rty, rkind) -> + (* Update the type info *) + let contains_static = r_is_static r in + let contains_borrow = true in + let contains_nested_borrows = expl_info.under_borrow in + let contains_borrow_under_mut = expl_info.under_mut_borrow in + let ty_b_info = + { + contains_static; + contains_borrow; + contains_nested_borrows; + contains_borrow_under_mut; + } + in + let ty_info = update_ty_info ty_info ty_b_info in + (* Update the exploration info *) + let expl_info = + { + under_borrow = true; + under_mut_borrow = expl_info.under_mut_borrow || rkind = Mut; + } + in + (* Continue exploring *) + analyze expl_info ty_info rty + | Adt ((Tuple | Assumed (Box | Vec | Option)), _, tys) -> + (* Nothing to update: just explore the type parameters *) + List.fold_left + (fun ty_info ty -> analyze expl_info ty_info ty) + ty_info tys + | Adt (AdtId adt_id, regions, tys) -> + (* Lookup the information for this type definition *) + let adt_info = TypeDeclId.Map.find adt_id infos in + (* Update the type info with the information from the adt *) + let ty_info = update_ty_info ty_info adt_info.borrows_info in + (* Check if 'static appears in the region parameters *) + let found_static = List.exists r_is_static regions in + let borrows_info = ty_info.borrows_info in + let borrows_info = + { + borrows_info with + contains_static = + check_update_bool borrows_info.contains_static found_static; + } + in + let ty_info = { ty_info with borrows_info } in + (* For every instantiated type parameter: update the exploration info + * then explore the type *) + let params_tys = List.combine adt_info.param_infos tys in + let ty_info = + List.fold_left + (fun ty_info (param_info, ty) -> + (* Update the type info *) + (* Below: we use only the information which we learn only + * by taking the type parameter into account. *) + let contains_static = false in + let contains_borrow = param_info.under_borrow in + let contains_nested_borrows = + expl_info.under_borrow && param_info.under_borrow + in + let contains_borrow_under_mut = + expl_info.under_mut_borrow && param_info.under_borrow + in + let ty_b_info = + { + contains_static; + contains_borrow; + contains_nested_borrows; + contains_borrow_under_mut; + } + in + let ty_info = update_ty_info ty_info ty_b_info in + (* Update the exploration info *) + let expl_info = + { + under_borrow = + expl_info.under_borrow || param_info.under_borrow; + under_mut_borrow = + expl_info.under_mut_borrow || param_info.under_mut_borrow; + } + in + (* Continue exploring *) + analyze expl_info ty_info ty) + ty_info params_tys + in + (* Return *) + ty_info + in + (* Explore *) + analyze expl_info_init ty_info ty + +let type_decl_is_opaque (d : type_decl) : bool = + match d.kind with Struct _ | Enum _ -> false | Opaque -> true + +let analyze_type_decl (updated : bool ref) (infos : type_infos) + (def : type_decl) : type_infos = + (* We analyze the type declaration only if it is not opaque (we need to explore + * the variants of the ADTs *) + if type_decl_is_opaque def then infos + else + (* Retrieve all the types of all the fields of all the variants *) + let fields_tys : sty list = + match def.kind with + | Struct fields -> List.map (fun f -> f.field_ty) fields + | Enum variants -> + List.concat + (List.map + (fun v -> List.map (fun f -> f.field_ty) v.fields) + variants) + | Opaque -> raise (Failure "unreachable") + in + (* Explore the types and accumulate information *) + let r_is_static r = r = Static in + let type_decl_info = TypeDeclId.Map.find def.def_id infos in + let type_decl_info = type_decl_info_to_partial_type_info type_decl_info in + let type_decl_info = + List.fold_left + (fun type_decl_info ty -> + analyze_full_ty r_is_static updated infos type_decl_info ty) + type_decl_info fields_tys + in + let type_decl_info = partial_type_info_to_type_decl_info type_decl_info in + (* Update the information for the type definition we explored *) + let infos = TypeDeclId.Map.add def.def_id type_decl_info infos in + (* Return *) + infos + +let analyze_type_declaration_group (type_decls : type_decl TypeDeclId.Map.t) + (infos : type_infos) (decl : type_declaration_group) : type_infos = + (* Collect the identifiers used in the declaration group *) + let ids = match decl with NonRec id -> [ id ] | Rec ids -> ids in + (* Retrieve the type definitions *) + let decl_defs = List.map (fun id -> TypeDeclId.Map.find id type_decls) ids in + (* Initialize the type information for the current definitions *) + let infos = + List.fold_left + (fun infos def -> + TypeDeclId.Map.add def.def_id (initialize_type_decl_info def) infos) + infos decl_defs + in + (* Analyze the types - this function simply computes a fixed-point *) + let updated : bool ref = ref false in + let rec analyze (infos : type_infos) : type_infos = + let infos = + List.fold_left + (fun infos def -> analyze_type_decl updated infos def) + infos decl_defs + in + if !updated then ( + updated := false; + analyze infos) + else infos + in + analyze infos + +(** Compute the type information for every *type definition* in a list of + declarations. This type definition information is later used to easily + compute the information of arbitrary types. + + Rk.: pay attention to the difference between type definitions and types! + *) +let analyze_type_declarations (type_decls : type_decl TypeDeclId.Map.t) + (decls : type_declaration_group list) : type_infos = + List.fold_left + (fun infos decl -> analyze_type_declaration_group type_decls infos decl) + TypeDeclId.Map.empty decls + +(** Analyze a type to check whether it contains borrows, etc., provided + we have already analyzed the type definitions in the context. + *) +let analyze_ty (infos : type_infos) (ty : 'r ty) : ty_info = + (* We don't use [updated] but need to give it as parameter *) + let updated = ref false in + (* We don't need to compute whether the type contains 'static or not *) + let r_is_static _ = false in + let ty_info = initialize_g_type_info None in + let ty_info = analyze_full_ty r_is_static updated infos ty_info ty in + (* Convert the ty_info *) + partial_type_info_to_ty_info ty_info diff --git a/compiler/TypesUtils.ml b/compiler/TypesUtils.ml new file mode 100644 index 00000000..7531dd8b --- /dev/null +++ b/compiler/TypesUtils.ml @@ -0,0 +1,190 @@ +open Types +open Utils +module TA = TypesAnalysis + +let type_decl_is_opaque (d : type_decl) : bool = + match d.kind with Struct _ | Enum _ -> false | Opaque -> true + +(** Retrieve the list of fields for the given variant of a {!Types.type_decl}. + + Raises [Invalid_argument] if the arguments are incorrect. + *) +let type_decl_get_fields (def : type_decl) + (opt_variant_id : VariantId.id option) : field list = + match (def.kind, opt_variant_id) with + | Enum variants, Some variant_id -> (VariantId.nth variants variant_id).fields + | Struct fields, None -> fields + | _ -> + let opt_variant_id = + match opt_variant_id with None -> "None" | Some _ -> "Some" + in + raise + (Invalid_argument + ("The variant id should be [Some] if and only if the definition is \ + an enumeration:\n\ + - def: " ^ show_type_decl def ^ "\n- opt_variant_id: " + ^ opt_variant_id)) + +(** Return [true] if a {!Types.ty} is actually [unit] *) +let ty_is_unit (ty : 'r ty) : bool = + match ty with Adt (Tuple, [], []) -> true | _ -> false + +let ty_is_adt (ty : 'r ty) : bool = + match ty with Adt (_, _, _) -> true | _ -> false + +let ty_as_adt (ty : 'r ty) : type_id * 'r list * 'r ty list = + match ty with + | Adt (id, regions, tys) -> (id, regions, tys) + | _ -> failwith "Unreachable" + +let ty_is_custom_adt (ty : 'r ty) : bool = + match ty with Adt (AdtId _, _, _) -> true | _ -> false + +let ty_as_custom_adt (ty : 'r ty) : TypeDeclId.id * 'r list * 'r ty list = + match ty with + | Adt (AdtId id, regions, tys) -> (id, regions, tys) + | _ -> failwith "Unreachable" + +(** The unit type *) +let mk_unit_ty : 'r ty = Adt (Tuple, [], []) + +(** The usize type *) +let mk_usize_ty : 'r ty = Integer Usize + +(** Deconstruct a type of the form [Box] to retrieve the [T] inside *) +let ty_get_box (box_ty : ety) : ety = + match box_ty with + | Adt (Assumed Box, [], [ boxed_ty ]) -> boxed_ty + | _ -> failwith "Not a boxed type" + +(** Deconstruct a type of the form [&T] or [&mut T] to retrieve the [T] (and + the borrow kind, etc.) + *) +let ty_get_ref (ty : 'r ty) : 'r * 'r ty * ref_kind = + match ty with + | Ref (r, ty, ref_kind) -> (r, ty, ref_kind) + | _ -> failwith "Not a ref type" + +let mk_ref_ty (r : 'r) (ty : 'r ty) (ref_kind : ref_kind) : 'r ty = + Ref (r, ty, ref_kind) + +(** Make a box type *) +let mk_box_ty (ty : 'r ty) : 'r ty = Adt (Assumed Box, [], [ ty ]) + +(** Make a vec type *) +let mk_vec_ty (ty : 'r ty) : 'r ty = Adt (Assumed Vec, [], [ ty ]) + +(** Check if a region is in a set of regions *) +let region_in_set (r : RegionId.id region) (rset : RegionId.Set.t) : bool = + match r with Static -> false | Var id -> RegionId.Set.mem id rset + +(** Return the set of regions in an rty *) +let rty_regions (ty : rty) : RegionId.Set.t = + let s = ref RegionId.Set.empty in + let add_region (r : RegionId.id region) = + match r with Static -> () | Var rid -> s := RegionId.Set.add rid !s + in + let obj = + object + inherit [_] iter_ty + method! visit_'r _env r = add_region r + end + in + (* Explore the type *) + obj#visit_ty () ty; + (* Return the set of accumulated regions *) + !s + +let rty_regions_intersect (ty : rty) (regions : RegionId.Set.t) : bool = + let ty_regions = rty_regions ty in + not (RegionId.Set.disjoint ty_regions regions) + +(** Convert an {!Types.ety}, containing no region variables, to an {!Types.rty} + or an {!Types.sty}. + + In practice, it is the identity. + *) +let rec ety_no_regions_to_gr_ty (ty : ety) : 'a gr_ty = + match ty with + | Adt (type_id, regions, tys) -> + assert (regions = []); + Adt (type_id, [], List.map ety_no_regions_to_gr_ty tys) + | TypeVar v -> TypeVar v + | Bool -> Bool + | Char -> Char + | Never -> Never + | Integer int_ty -> Integer int_ty + | Str -> Str + | Array ty -> Array (ety_no_regions_to_gr_ty ty) + | Slice ty -> Slice (ety_no_regions_to_gr_ty ty) + | Ref (_, _, _) -> + failwith + "Can't convert a ref with erased regions to a ref with non-erased \ + regions" + +let ety_no_regions_to_rty (ty : ety) : rty = ety_no_regions_to_gr_ty ty +let ety_no_regions_to_sty (ty : ety) : sty = ety_no_regions_to_gr_ty ty + +(** Retuns true if the type contains borrows. + + Note that we can't simply explore the type and look for regions: sometimes + we erase the lists of regions (by replacing them with [[]] when using {!Types.ety}, + and when a type uses 'static this region doesn't appear in the region parameters. + *) +let ty_has_borrows (infos : TA.type_infos) (ty : 'r ty) : bool = + let info = TA.analyze_ty infos ty in + info.TA.contains_borrow + +(** Retuns true if the type contains nested borrows. + + Note that we can't simply explore the type and look for regions: sometimes + we erase the lists of regions (by replacing them with [[]] when using {!Types.ety}, + and when a type uses 'static this region doesn't appear in the region parameters. + *) +let ty_has_nested_borrows (infos : TA.type_infos) (ty : 'r ty) : bool = + let info = TA.analyze_ty infos ty in + info.TA.contains_nested_borrows + +(** Retuns true if the type contains a borrow under a mutable borrow *) +let ty_has_borrow_under_mut (infos : TA.type_infos) (ty : 'r ty) : bool = + let info = TA.analyze_ty infos ty in + info.TA.contains_borrow_under_mut + +(** Check if a {!Types.ty} contains regions from a given set *) +let ty_has_regions_in_set (rset : RegionId.Set.t) (ty : rty) : bool = + let obj = + object + inherit [_] iter_ty as super + + method! visit_Adt env type_id regions tys = + List.iter (fun r -> if region_in_set r rset then raise Found) regions; + super#visit_Adt env type_id regions tys + + method! visit_Ref env r ty rkind = + if region_in_set r rset then raise Found + else super#visit_Ref env r ty rkind + end + in + try + obj#visit_ty () ty; + false + with Found -> true + +(** Return true if a type is "primitively copyable". + * + * "primitively copyable" means that copying instances of this type doesn't + * require calling dedicated functions defined through the Copy trait. It + * is the case for types like integers, shared borrows, etc. + * + * Generally, ADTs are not copyable. However, some of the primitive ADTs are + * like `Option`. + *) +let rec ty_is_primitively_copyable (ty : 'r ty) : bool = + match ty with + | Adt (Assumed Option, _, tys) -> List.for_all ty_is_primitively_copyable tys + | Adt ((AdtId _ | Assumed (Box | Vec)), _, _) -> false + | Adt (Tuple, _, tys) -> List.for_all ty_is_primitively_copyable tys + | TypeVar _ | Never | Str | Array _ | Slice _ -> false + | Bool | Char | Integer _ -> true + | Ref (_, _, Mut) -> false + | Ref (_, _, Shared) -> true diff --git a/compiler/Utils.ml b/compiler/Utils.ml new file mode 100644 index 00000000..a285e869 --- /dev/null +++ b/compiler/Utils.ml @@ -0,0 +1,6 @@ +exception Found +(** Utility exception + + When looking for something while exploring a term, it can be easier to + just throw an exception to signal we found what we were looking for. + *) diff --git a/compiler/Values.ml b/compiler/Values.ml new file mode 100644 index 00000000..e404f40d --- /dev/null +++ b/compiler/Values.ml @@ -0,0 +1,844 @@ +open Identifiers +open Types + +(* TODO: I often write "abstract" (value, borrow content, etc.) while I should + * write "abstraction" (because those values are not abstract, they simply are + * inside abstractions) *) + +module VarId = IdGen () +module BorrowId = IdGen () +module SymbolicValueId = IdGen () +module AbstractionId = IdGen () +module FunCallId = IdGen () + +(** A variable *) + +type big_int = Z.t + +let big_int_of_yojson (json : Yojson.Safe.t) : (big_int, string) result = + match json with + | `Int i -> Ok (Z.of_int i) + | `Intlit is -> Ok (Z.of_string is) + | _ -> Error "not an integer or an integer literal" + +let big_int_to_yojson (i : big_int) = `Intlit (Z.to_string i) + +let pp_big_int (fmt : Format.formatter) (bi : big_int) : unit = + Format.pp_print_string fmt (Z.to_string bi) + +let show_big_int (bi : big_int) : string = Z.to_string bi + +(** A scalar value + + Note that we use unbounded integers everywhere. + We then harcode the boundaries for the different types. + *) +type scalar_value = { value : big_int; int_ty : integer_type } [@@deriving show] + +(** A constant value *) +type constant_value = + | Scalar of scalar_value + | Bool of bool + | Char of char + | String of string +[@@deriving show] + +(** The kind of a symbolic value, which precises how the value was generated *) +type sv_kind = + | FunCallRet (** The value is the return value of a function call *) + | FunCallGivenBack + (** The value is a borrowed value given back by an abstraction + (happens when giving a borrow to a function: when the abstraction + introduced to model the function call ends we reintroduce a symbolic + value in the context for the value modified by the abstraction through + the borrow). + *) + | SynthInput + (** The value is an input value of the function whose body we are + currently synthesizing. + *) + | SynthRetGivenBack + (** The value is a borrowed value that the function whose body we are + synthesizing returned, and which was given back because we ended + one of the lifetimes of this function (we do this to synthesize + the backward functions). + *) + | SynthInputGivenBack + (** The value was given back upon ending one of the input abstractions *) + | Global (** The value is a global *) +[@@deriving show] + +(** A symbolic value *) +type symbolic_value = { + sv_kind : sv_kind; + sv_id : SymbolicValueId.id; + sv_ty : rty; +} +[@@deriving show] + +(** Ancestor for {!typed_value} iter visitor *) +class ['self] iter_typed_value_base = + object (_self : 'self) + inherit [_] VisitorsRuntime.iter + method visit_constant_value : 'env -> constant_value -> unit = fun _ _ -> () + method visit_erased_region : 'env -> erased_region -> unit = fun _ _ -> () + method visit_symbolic_value : 'env -> symbolic_value -> unit = fun _ _ -> () + method visit_ety : 'env -> ety -> unit = fun _ _ -> () + end + +(** Ancestor for {!typed_value} map visitor for *) +class ['self] map_typed_value_base = + object (_self : 'self) + inherit [_] VisitorsRuntime.map + + method visit_constant_value : 'env -> constant_value -> constant_value = + fun _ cv -> cv + + method visit_erased_region : 'env -> erased_region -> erased_region = + fun _ r -> r + + method visit_symbolic_value : 'env -> symbolic_value -> symbolic_value = + fun _ sv -> sv + + method visit_ety : 'env -> ety -> ety = fun _ ty -> ty + end + +(** An untyped value, used in the environments *) +type value = + | Concrete of constant_value (** Concrete (non-symbolic) value *) + | Adt of adt_value (** Enumerations and structures *) + | Bottom (** No value (uninitialized or moved value) *) + | Borrow of borrow_content (** A borrowed value *) + | Loan of loan_content (** A loaned value *) + | Symbolic of symbolic_value + (** Borrow projector over a symbolic value. + + Note that contrary to the abstraction-values case, symbolic values + appearing in regular values are interpreted as *borrow* projectors, + they can never be *loan* projectors. + *) + +and adt_value = { + variant_id : (VariantId.id option[@opaque]); + field_values : typed_value list; +} + +and borrow_content = + | SharedBorrow of mvalue * (BorrowId.id[@opaque]) + (** A shared borrow. + + We remember the shared value which was borrowed as a meta value. + This is necessary for synthesis: upon translating to "pure" values, + we can't perform any lookup because we don't have an environment + anymore. Note that it is ok to keep the shared value and copy + the shared value this way, because shared values are immutable + for as long as they are shared (i.e., as long as we can use the + shared borrow). + *) + | MutBorrow of (BorrowId.id[@opaque]) * typed_value + (** A mutably borrowed value. *) + | InactivatedMutBorrow of mvalue * (BorrowId.id[@opaque]) + (** An inactivated mut borrow. + + This is used to model {{: https://rustc-dev-guide.rust-lang.org/borrow_check/two_phase_borrows.html} two-phase borrows}. + When evaluating a two-phase mutable borrow, we first introduce an inactivated + borrow which behaves like a shared borrow, until the moment we actually *use* + the borrow: at this point, we end all the other shared borrows (or inactivated + borrows - though there shouldn't be any other inactivated borrows if the program + is well typed) of this value and replace the inactivated borrow with a + mutable borrow. + + A simple use case of two-phase borrows: + {[ + let mut v = Vec::new(); + v.push(v.len()); + ]} + + This gets desugared to (something similar to) the following MIR: + {[ + v = Vec::new(); + v1 = &mut v; + v2 = &v; // We need this borrow, but v has already been mutably borrowed! + l = Vec::len(move v2); + Vec::push(move v1, move l); // In practice, v1 gets activated only here + ]} + + The meta-value is used for the same purposes as with shared borrows, + at the exception that in case of inactivated borrows it is not + *necessary* for the synthesis: we keep it only as meta-information. + To be more precise: + - when generating the synthesized program, we may need to convert + shared borrows to pure values + - we never need to do so for inactivated borrows: such borrows must + be activated at the moment we use them (meaning we convert a *mutable* + borrow to a pure value). However, we save meta-data about the assignments, + which is used to make the code cleaner: when generating this meta-data, + we may need to convert inactivated borrows to pure values, in which + situation we convert the meta-value we stored in the inactivated + borrow. + *) + +and loan_content = + | SharedLoan of (BorrowId.Set.t[@opaque]) * typed_value + | MutLoan of (BorrowId.id[@opaque]) + (** TODO: we might want to add a set of borrow ids (useful for inactivated + borrows, and extremely useful when giving shared values to abstractions). + *) + +(** "Meta"-value: information we store for the synthesis. + + Note that we never automatically visit the meta-values with the + visitors: they really are meta information, and shouldn't be considered + as part of the environment during a symbolic execution. + + TODO: we may want to create wrappers, to prevent accidently mixing meta + values and regular values. + *) +and mvalue = typed_value + +(** "Regular" typed value (we map variables to typed values) *) +and typed_value = { value : value; ty : ety } +[@@deriving + show, + visitors + { + name = "iter_typed_value_visit_mvalue"; + variety = "iter"; + ancestors = [ "iter_typed_value_base" ]; + nude = true (* Don't inherit {!VisitorsRuntime.iter} *); + concrete = true; + }, + visitors + { + name = "map_typed_value_visit_mvalue"; + variety = "map"; + ancestors = [ "map_typed_value_base" ]; + nude = true (* Don't inherit {!VisitorsRuntime.iter} *); + concrete = true; + }] + +(** We have to override the {!iter_typed_value_visit_mvalue.visit_mvalue} method, + to ignore meta-values *) +class ['self] iter_typed_value = + object (_self : 'self) + inherit [_] iter_typed_value_visit_mvalue + method! visit_mvalue : 'env -> mvalue -> unit = fun _ _ -> () + end + +(** We have to override the {!iter_typed_value_visit_mvalue.visit_mvalue} method, + to ignore meta-values *) +class ['self] map_typed_value = + object (_self : 'self) + inherit [_] map_typed_value_visit_mvalue + method! visit_mvalue : 'env -> mvalue -> mvalue = fun _ x -> x + end + +(** "Meta"-symbolic value. + + See the explanations for {!mvalue} + + TODO: we may want to create wrappers, to prevent mixing meta values + and regular values. + *) +type msymbolic_value = symbolic_value [@@deriving show] + +(** When giving shared borrows to functions (i.e., inserting shared borrows inside + abstractions) we need to reborrow the shared values. When doing so, we lookup + the shared values and apply some special projections to the shared value + (until we can't go further, i.e., we find symbolic values which may get + expanded upon reading them later), which don't generate avalues but + sets of borrow ids and symbolic values. + + Note that as shared values can't get modified it is ok to forget the + structure of the values we projected, and only keep the set of borrows + (and symbolic values). + + TODO: we may actually need to remember the structure, in order to know + which borrows are inside which other borrows... +*) +type abstract_shared_borrow = + | AsbBorrow of (BorrowId.id[@opaque]) + | AsbProjReborrows of (symbolic_value[@opaque]) * (rty[@opaque]) +[@@deriving show] + +(** A set of abstract shared borrows *) +type abstract_shared_borrows = abstract_shared_borrow list [@@deriving show] + +(** Ancestor for {!aproj} iter visitor *) +class ['self] iter_aproj_base = + object (_self : 'self) + inherit [_] iter_typed_value + method visit_rty : 'env -> rty -> unit = fun _ _ -> () + + method visit_msymbolic_value : 'env -> msymbolic_value -> unit = + fun _ _ -> () + end + +(** Ancestor for {!aproj} map visitor *) +class ['self] map_aproj_base = + object (_self : 'self) + inherit [_] map_typed_value + method visit_rty : 'env -> rty -> rty = fun _ ty -> ty + + method visit_msymbolic_value : 'env -> msymbolic_value -> msymbolic_value = + fun _ m -> m + end + +type aproj = + | AProjLoans of symbolic_value * (msymbolic_value * aproj) list + (** A projector of loans over a symbolic value. + + Note that the borrows of a symbolic value may be spread between + different abstractions, meaning that the projector of loans might + receive *several* (symbolic) given back values. + + This is the case in the following example: + {[ + fn f<'a> (...) -> (&'a mut u32, &'a mut u32); + fn g<'b, 'c>(p : (&'b mut u32, &'c mut u32)); + + let p = f(...); + g(move p); + + // Symbolic context after the call to g: + // abs'a {'a} { [s@0 <: (&'a mut u32, &'a mut u32)] } + // + // abs'b {'b} { (s@0 <: (&'b mut u32, &'c mut u32)) } + // abs'c {'c} { (s@0 <: (&'b mut u32, &'c mut u32)) } + ]} + + Upon evaluating the call to [f], we introduce a symbolic value [s@0] + and a projector of loans (projector loans from the region 'c). + This projector will later receive two given back values: one for + 'a and one for 'b. + + We accumulate those values in the list of projections (note that + the meta value stores the value which was given back). + + We can later end the projector of loans if [s@0] is not referenced + anywhere in the context below a projector of borrows which intersects + this projector of loans. + *) + | AProjBorrows of symbolic_value * rty + (** Note that an AProjBorrows only operates on a value which is not below + a shared loan: under a shared loan, we use {!abstract_shared_borrow}. + + Also note that once given to a borrow projection, a symbolic value + can't get updated/expanded: this means that we don't need to save + any meta-value here. + *) + | AEndedProjLoans of msymbolic_value * (msymbolic_value * aproj) list + (** An ended projector of loans over a symbolic value. + + See the explanations for {!AProjLoans} + + Note that we keep the original symbolic value as a meta-value. + *) + | AEndedProjBorrows of msymbolic_value + (** The only purpose of {!AEndedProjBorrows} is to store, for synthesis + purposes, the symbolic value which was generated and given back upon + ending the borrow. + *) + | AIgnoredProjBorrows +[@@deriving + show, + visitors + { + name = "iter_aproj"; + variety = "iter"; + ancestors = [ "iter_aproj_base" ]; + nude = true (* Don't inherit {!VisitorsRuntime.iter} *); + concrete = true; + }, + visitors + { + name = "map_aproj"; + variety = "map"; + ancestors = [ "map_aproj_base" ]; + nude = true (* Don't inherit {!VisitorsRuntime.iter} *); + concrete = true; + }] + +type region = RegionVarId.id Types.region [@@deriving show] + +(** Ancestor for {!typed_avalue} iter visitor *) +class ['self] iter_typed_avalue_base = + object (_self : 'self) + inherit [_] iter_aproj + method visit_id : 'env -> BorrowId.id -> unit = fun _ _ -> () + method visit_region : 'env -> region -> unit = fun _ _ -> () + + method visit_abstract_shared_borrows + : 'env -> abstract_shared_borrows -> unit = + fun _ _ -> () + end + +(** Ancestor for {!typed_avalue} map visitor *) +class ['self] map_typed_avalue_base = + object (_self : 'self) + inherit [_] map_aproj + method visit_id : 'env -> BorrowId.id -> BorrowId.id = fun _ id -> id + method visit_region : 'env -> region -> region = fun _ r -> r + + method visit_abstract_shared_borrows + : 'env -> abstract_shared_borrows -> abstract_shared_borrows = + fun _ asb -> asb + end + +(** Abstraction values are used inside of abstractions to properly model + borrowing relations introduced by function calls. + + When calling a function, we lose information about the borrow graph: + part of it is thus "abstracted" away. +*) +type avalue = + | AConcrete of constant_value + (** TODO: remove. We actually don't use that for the synthesis, but the + meta-values. + + Note that this case is not used in the projections to keep track of the + borrow graph (because there are no borrows in "concrete" values!) but + to correctly instantiate the backward functions (we may give back some + values at different moments: we need to remember what those values were + precisely). Also note that even though avalues and values are not the + same, once values are projected to avalues, those avalues still have + the structure of the original values (this is necessary, again, to + correctly instantiate the backward functions) + *) + | AAdt of adt_avalue + | ABottom + | ALoan of aloan_content + | ABorrow of aborrow_content + | ASymbolic of aproj + | AIgnored + (** A value which doesn't contain borrows, or which borrows we + don't own and thus ignore *) + +and adt_avalue = { + variant_id : (VariantId.id option[@opaque]); + field_values : typed_avalue list; +} + +(** A loan content as stored in an abstraction. + + Note that the children avalues are independent of the parent avalues. + For instance, the child avalue contained in an {!AMutLoan} will likely + contain other, independent loans. + Keeping track of the hierarchy is not necessary to maintain the borrow graph + (which is the primary role of the abstractions), but it is necessary + to properly instantiate the backward functions when generating the pure + translation. +*) +and aloan_content = + | AMutLoan of (BorrowId.id[@opaque]) * typed_avalue + (** A mutable loan owned by an abstraction. + + Example: + ======== + {[ + fn f<'a>(...) -> &'a mut &'a mut u32; + + let px = f(...); + ]} + + We get (after some symbolic exansion): + {[ + abs0 { + a_mut_loan l0 (a_mut_loan l1) + } + px -> mut_borrow l0 (mut_borrow @s1) + ]} + *) + | ASharedLoan of (BorrowId.Set.t[@opaque]) * typed_value * typed_avalue + (** A shared loan owned by an abstraction. + + Example: + ======== + {[ + fn f<'a>(...) -> &'a u32; + + let px = f(...); + ]} + + We get: + {[ + abs0 { a_shared_loan {l0} @s0 ⊥ } + px -> shared_loan l0 + ]} + *) + | AEndedMutLoan of { + child : typed_avalue; + given_back : typed_avalue; + given_back_meta : mvalue; + } + (** An ended mutable loan in an abstraction. + We need it because abstractions must keep track of the values + we gave back to them, so that we can correctly instantiate + backward functions. + + Rk.: *DO NOT* use [visit_AEndedMutLoan]. If we update the order of + the arguments and you forget to swap them at the level of + [visit_AEndedMutLoan], you will not notice it. + + Example: + ======== + {[ + abs0 { a_mut_loan l0 ⊥ } + x -> mut_borrow l0 (U32 3) + ]} + + After ending [l0]: + + {[ + abs0 { a_ended_mut_loan { given_back = U32 3; child = ⊥; } + x -> ⊥ + ]} + *) + | AEndedSharedLoan of typed_value * typed_avalue + (** Similar to {!AEndedMutLoan} but in this case there are no avalues to + give back. We keep the shared value because it now behaves as a + "regular" value (which contains borrows we might want to end...). + *) + | AIgnoredMutLoan of (BorrowId.id[@opaque]) * typed_avalue + (** An ignored mutable loan. + + We need to keep track of ignored mutable loans, because we may have + to apply projections on the values given back to those loans (say + you have a borrow of type [&'a mut &'b mut], in the abstraction 'b, + the outer loan is ignored, however you need to keep track of it so + that when ending the borrow corresponding to 'a you can correctly + project on the inner value). + + Example: + ======== + {[ + fn f<'a,'b>(...) -> &'a mut &'b mut u32; + let x = f(...); + + > abs'a { a_mut_loan l0 (a_ignored_mut_loan l1 ⊥) } + > abs'b { a_ignored_mut_loan l0 (a_mut_loan l1 ⊥) } + > x -> mut_borrow l0 (mut_borrow l1 @s1) + ]} + *) + | AEndedIgnoredMutLoan of { + child : typed_avalue; + given_back : typed_avalue; + given_back_meta : mvalue; + } + (** Similar to {!AEndedMutLoan}, for ignored loans. + + Rk.: *DO NOT* use [visit_AEndedIgnoredMutLoan]. + See the comment for {!AEndedMutLoan}. + *) + | AIgnoredSharedLoan of typed_avalue + (** An ignored shared loan. + + Example: + ======== + {[ + fn f<'a,'b>(...) -> &'a &'b u32; + let x = f(...); + + > abs'a { a_shared_loan {l0} (shared_borrow l1) (a_ignored_shared_loan ⊥) } + > abs'b { a_ignored_shared_loan (a_shared_loan {l1} @s1 ⊥) } + > x -> shared_borrow l0 + ]} + *) + +(** Note that when a borrow content is ended, it is replaced by ⊥ (while + we need to track ended loans more precisely, especially because of their + children values). + + Note that contrary to {!aloan_content}, here the children avalues are + not independent of the parent avalues. For instance, a value + [AMutBorrow (_, AMutBorrow (_, ...)] (ignoring the types) really is + to be seen like a [mut_borrow ... (mut_borrow ...)]. + + TODO: be more precise about the ignored borrows (keep track of the borrow + ids)? +*) +and aborrow_content = + | AMutBorrow of mvalue * (BorrowId.id[@opaque]) * typed_avalue + (** A mutable borrow owned by an abstraction. + + Is used when an abstraction "consumes" borrows, when giving borrows + as arguments to a function. + + Example: + ======== + {[ + fn f<'a>(px : &'a mut u32); + + > x -> mut_loan l0 + > px -> mut_borrow l0 (U32 0) + + f(move px); + + > x -> mut_loan l0 + > px -> ⊥ + > abs0 { a_mut_borrow l0 (U32 0) } + ]} + + The meta-value stores the initial value on which the projector was + applied, which reduced to this mut borrow. This meta-information + is only used for the synthesis. + TODO: do we really use it actually? + *) + | ASharedBorrow of (BorrowId.id[@opaque]) + (** A shared borrow owned by an abstraction. + + Example: + ======== + {[ + fn f<'a>(px : &'a u32); + + > x -> shared_loan {l0} (U32 0) + > px -> shared_borrow l0 + + f(move px); + + > x -> shared_loan {l0} (U32 0) + > px -> ⊥ + > abs0 { a_shared_borrow l0 } + ]} + *) + | AIgnoredMutBorrow of BorrowId.id option * typed_avalue + (** An ignored mutable borrow. + + We need to keep track of ignored mut borrows because when ending such + borrows, we need to project the loans of the given back value to + insert them in the proper abstractions. + + Note that we need to do so only for borrows consumed by parent + abstractions (hence the optional borrow id). + + TODO: the below explanations are obsolete + + Example: + ======== + {[ + fn f<'a,'b>(ppx : &'a mut &'b mut u32); + + > x -> mut_loan l0 + > px -> mut_loan l1 + > ppx -> mut_borrow l1 (mut_borrow l0 (U32 0)) + + f(move ppx); + + > x -> mut_loan l0 + > px -> mut_loan l1 + > ppx -> ⊥ + > abs'a { a_mut_borrow l1 (a_ignored_mut_borrow None (U32 0)) } // TODO: duplication + > abs'b {parents={abs'a}} { a_ignored_mut_borrow (Some l1) (a_mut_borrow l0 (U32 0)) } + + ... // abs'a ends + + > x -> mut_loan l0 + > px -> @s0 + > ppx -> ⊥ + > abs'b { + > a_ended_ignored_mut_borrow (a_proj_loans (@s0 <: &'b mut u32)) // <-- loan projector + > (a_mut_borrow l0 (U32 0)) + > } + + ... // [@s0] gets expanded to [&mut l2 @s1] + + > x -> mut_loan l0 + > px -> &mut l2 @s1 + > ppx -> ⊥ + > abs'b { + > a_ended_ignored_mut_borrow (a_mut_loan l2) // <-- loan l2 is here + > (a_mut_borrow l0 (U32 0)) + > } + + ]} + + Note that we could use AIgnoredMutLoan in the case the borrow id is not + None, which would allow us to simplify the rules (to not have rules + to specifically handle the case of AIgnoredMutBorrow with Some borrow + id) and also remove the AEndedIgnoredMutBorrow variant. + For now, the rules are implemented and it allows us to make the avalues + more precise and clearer, so we will keep it that way. + + TODO: this is annoying, we are duplicating information. Maybe we + could introduce an "Ignored" value? We have to pay attention to + two things: + - introducing ⊥ when ignoring a value is not always possible, because + we check whether the borrowed value contains ⊥ when giving back a + borrowed value (if it is the case we give back ⊥, otherwise we + introduce a symbolic value). This is necessary when ending nested + borrows with the same lifetime: when ending the inner borrow we + actually give back a value, however when ending the outer borrow + we need to give back ⊥. + TODO: actually we don't do that anymore, we check if the borrowed + avalue contains ended regions (which is cleaner and more robust). + - we may need to remember the precise values given to the + abstraction so that we can properly call the backward functions + when generating the pure translation. + *) + | AEndedMutBorrow of msymbolic_value * typed_avalue + (** The sole purpose of {!AEndedMutBorrow} is to store the (symbolic) value + that we gave back as a meta-value, to help with the synthesis. + + We also remember the child {!avalue} because this structural information + is useful for the synthesis (but not for the symbolic execution): + in practice the child value should only contain ended borrows, ignored + values, bottom values, etc. + *) + | AEndedSharedBorrow + (** We don't really need {!AEndedSharedBorrow}: we simply want to be + precise, and not insert ⊥ when ending borrows. + *) + | AEndedIgnoredMutBorrow of { + child : typed_avalue; + given_back_loans_proj : typed_avalue; + given_back_meta : msymbolic_value; + (** [given_back_meta] is used to store the (symbolic) value we gave back + upon ending the borrow. + + Rk.: *DO NOT* use [visit_AEndedIgnoredMutLoan]. + See the comment for {!AEndedMutLoan}. + *) + } (** See the explanations for {!AIgnoredMutBorrow} *) + | AProjSharedBorrow of abstract_shared_borrows + (** A projected shared borrow. + + When giving shared borrows as arguments to function calls, we + introduce new borrows to keep track of the fact that the function + might reborrow values inside. Note that as shared values are immutable, + we don't really need to remember the structure of the shared values. + + Example: + ======== + Below, when calling [f], we need to introduce one shared borrow per + borrow in the argument. + {[ + fn f<'a,'b>(pppx : &'a &'b &'c mut u32); + + > x -> mut_loan l0 + > px -> shared_loan {l1} (mut_borrow l0 (U32 0)) + > ppx -> shared_loan {l2} (shared_borrow l1) + > pppx -> shared_borrow l2 + + f(move pppx); + + > x -> mut_loan l0 + > px -> shared_loan {l1, l3, l4} (mut_borrow l0 (U32 0)) + > ppx -> shared_loan {l2} (shared_borrow l1) + > pppx -> ⊥ + > abs'a { a_proj_shared_borrow {l2} } + > abs'b { a_proj_shared_borrow {l3} } // l3 reborrows l1 + > abs'c { a_proj_shared_borrow {l4} } // l4 reborrows l0 + ]} + *) + +(* TODO: the type of avalues doesn't make sense for loan avalues: they currently + are typed as [& (mut) T] instead of [T]... +*) +and typed_avalue = { value : avalue; ty : rty } +[@@deriving + show, + visitors + { + name = "iter_typed_avalue"; + variety = "iter"; + ancestors = [ "iter_typed_avalue_base" ]; + nude = true (* Don't inherit {!VisitorsRuntime.iter} *); + concrete = true; + }, + visitors + { + name = "map_typed_avalue"; + variety = "map"; + ancestors = [ "map_typed_avalue_base" ]; + nude = true (* Don't inherit {!VisitorsRuntime.iter} *); + concrete = true; + }] + +(** The kind of an abstraction, which keeps track of its origin *) +type abs_kind = + | FunCall (** The abstraction was introduced because of a function call *) + | SynthInput + (** The abstraction keeps track of the input values of the function + we are currently synthesizing. *) + | SynthRet + (** The abstraction "absorbed" the value returned by the function we + are currently synthesizing *) +[@@deriving show] + +(** Abstractions model the parts in the borrow graph where the borrowing relations + have been abstracted because of a function call. + + In order to model the relations between the borrows, we use "abstraction values", + which are a special kind of value. +*) +type abs = { + abs_id : (AbstractionId.id[@opaque]); + call_id : (FunCallId.id[@opaque]); + (** The identifier of the function call which introduced this + abstraction. This is not used by the symbolic execution: + this is only used for pretty-printing and debugging, in the + symbolic AST, generated by the symbolic execution. + *) + back_id : (RegionGroupId.id[@opaque]); + (** The region group id to which this abstraction is linked. + + In most situations, it gives the id of the backward function (hence + the name), but it is a bit more subtle in the case of synth input + and synth ret abstractions. + + This is not used by the symbolic execution: it is a utility for + the symbolic AST, generated by the symbolic execution. + *) + kind : (abs_kind[@opaque]); + can_end : (bool[@opaque]); + (** Controls whether the region can be ended or not. + + This allows to "pin" some regions, and is useful when generating + backward functions. + + For instance, if we have: [fn f<'a, 'b>(...) -> (&'a mut T, &'b mut T)], + when generating the backward function for 'a, we have to make sure we + don't need to end the return region for 'b (if it is the case, it means + the function doesn't borrow check). + *) + parents : (AbstractionId.Set.t[@opaque]); (** The parent abstractions *) + original_parents : (AbstractionId.id list[@opaque]); + (** The original list of parents, ordered. This is used for synthesis. *) + regions : (RegionId.Set.t[@opaque]); (** Regions owned by this abstraction *) + ancestors_regions : (RegionId.Set.t[@opaque]); + (** Union of the regions owned by this abstraction's ancestors (not + including the regions of this abstraction itself) *) + avalues : typed_avalue list; (** The values in this abstraction *) +} +[@@deriving + show, + visitors + { + name = "iter_abs"; + variety = "iter"; + ancestors = [ "iter_typed_avalue" ]; + nude = true (* Don't inherit {!VisitorsRuntime.iter} *); + concrete = true; + }, + visitors + { + name = "map_abs"; + variety = "map"; + ancestors = [ "map_typed_avalue" ]; + nude = true (* Don't inherit {!VisitorsRuntime.iter} *); + concrete = true; + }] + +(** A symbolic expansion + + A symbolic expansion doesn't represent a value, but rather an operation + that we apply to values. + + TODO: this should rather be name "expanded_symbolic" + *) +type symbolic_expansion = + | SeConcrete of constant_value + | SeAdt of (VariantId.id option * symbolic_value list) + | SeMutRef of BorrowId.id * symbolic_value + | SeSharedRef of BorrowId.Set.t * symbolic_value diff --git a/compiler/ValuesUtils.ml b/compiler/ValuesUtils.ml new file mode 100644 index 00000000..72d7abe0 --- /dev/null +++ b/compiler/ValuesUtils.ml @@ -0,0 +1,121 @@ +open Utils +open TypesUtils +open Types +open Values +module TA = TypesAnalysis + +(** Utility exception *) +exception FoundSymbolicValue of symbolic_value + +let mk_unit_value : typed_value = + { value = Adt { variant_id = None; field_values = [] }; ty = mk_unit_ty } + +let mk_typed_value (ty : ety) (value : value) : typed_value = { value; ty } +let mk_bottom (ty : ety) : typed_value = { value = Bottom; ty } + +(** Box a value *) +let mk_box_value (v : typed_value) : typed_value = + let box_ty = mk_box_ty v.ty in + let box_v = Adt { variant_id = None; field_values = [ v ] } in + mk_typed_value box_ty box_v + +let is_bottom (v : value) : bool = match v with Bottom -> true | _ -> false + +let is_symbolic (v : value) : bool = + match v with Symbolic _ -> true | _ -> false + +let as_symbolic (v : value) : symbolic_value = + match v with Symbolic s -> s | _ -> failwith "Unexpected" + +let as_mut_borrow (v : typed_value) : BorrowId.id * typed_value = + match v.value with + | Borrow (MutBorrow (bid, bv)) -> (bid, bv) + | _ -> failwith "Unexpected" + +(** Check if a value contains a borrow *) +let borrows_in_value (v : typed_value) : bool = + let obj = + object + inherit [_] iter_typed_value + method! visit_borrow_content _env _ = raise Found + end + in + (* We use exceptions *) + try + obj#visit_typed_value () v; + false + with Found -> true + +(** Check if a value contains inactivated mutable borrows *) +let inactivated_in_value (v : typed_value) : bool = + let obj = + object + inherit [_] iter_typed_value + method! visit_InactivatedMutBorrow _env _ = raise Found + end + in + (* We use exceptions *) + try + obj#visit_typed_value () v; + false + with Found -> true + +(** Check if a value contains a loan *) +let loans_in_value (v : typed_value) : bool = + let obj = + object + inherit [_] iter_typed_value + method! visit_loan_content _env _ = raise Found + end + in + (* We use exceptions *) + try + obj#visit_typed_value () v; + false + with Found -> true + +(** Check if a value contains outer loans (i.e., loans which are not in borrwed + values. *) +let outer_loans_in_value (v : typed_value) : bool = + let obj = + object + inherit [_] iter_typed_value + method! visit_loan_content _env _ = raise Found + method! visit_borrow_content _ _ = () + end + in + (* We use exceptions *) + try + obj#visit_typed_value () v; + false + with Found -> true + +let find_first_primitively_copyable_sv_with_borrows (type_infos : TA.type_infos) + (v : typed_value) : symbolic_value option = + (* The visitor *) + let obj = + object + inherit [_] iter_typed_value + + method! visit_Symbolic _ sv = + let ty = sv.sv_ty in + if ty_is_primitively_copyable ty && ty_has_borrows type_infos ty then + raise (FoundSymbolicValue sv) + else () + end + in + (* Small helper *) + try + obj#visit_typed_value () v; + None + with FoundSymbolicValue sv -> Some sv + +(** Strip the outer shared loans in a value. + Ex.: + [shared_loan {l0, l1} (3 : u32, shared_loan {l2} (4 : u32))] ~~> + [(3 : u32, shared_loan {l2} (4 : u32))] + *) +let rec value_strip_shared_loans (v : typed_value) : typed_value = + match v.value with + | Loan (SharedLoan (_, v')) -> value_strip_shared_loans v' + | _ -> v diff --git a/compiler/aeneas.opam b/compiler/aeneas.opam new file mode 100644 index 00000000..4048f9a0 --- /dev/null +++ b/compiler/aeneas.opam @@ -0,0 +1,29 @@ +# This file is generated by dune, edit dune-project instead +opam-version: "2.0" +version: "0.1" +synopsis: "" +description: "" +maintainer: ["son.ho@inria.fr"] +authors: ["Son Ho" "Jonathan Protzenko" "Aymeric Fromherz" "Sidney Congard"] +license: "Apache-2.0" +homepage: "https://github.com/AeneasVerif/aeneas" +bug-reports: "https://github.com/AeneasVerif/aeneas/issues" +depends: [ + "dune" {>= "2.8"} + "odoc" {with-doc} +] +build: [ + ["dune" "subst"] {dev} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "@install" + "@runtest" {with-test} + "@doc" {with-doc} + ] +] +dev-repo: "git+https://github.com/AeneasVerif/aeneas.git" diff --git a/compiler/driver.ml b/compiler/driver.ml new file mode 100644 index 00000000..ae9d238a --- /dev/null +++ b/compiler/driver.ml @@ -0,0 +1,208 @@ +open Aeneas.LlbcOfJson +open Aeneas.Logging +open Aeneas.Print +module T = Aeneas.Types +module A = Aeneas.LlbcAst +module I = Aeneas.Interpreter +module EL = Easy_logging.Logging +module TA = Aeneas.TypesAnalysis +module Micro = Aeneas.PureMicroPasses +module Print = Aeneas.Print +module PrePasses = Aeneas.PrePasses +module Translate = Aeneas.Translate + +(* This is necessary to have a backtrace when raising exceptions - for some + * reason, the -g option doesn't work. + * TODO: run with OCAMLRUNPARAM=b=1? *) +let () = Printexc.record_backtrace true + +let usage = + Printf.sprintf + {|Aeneas: verification of Rust programs by translation to pure lambda calculus + +Usage: %s [OPTIONS] FILE +|} + Sys.argv.(0) + +let () = + (* Measure start time *) + let start_time = Unix.gettimeofday () in + + (* Read the command line arguments *) + let dest_dir = ref "" in + let decompose_monads = ref false in + let unfold_monads = ref true in + let filter_useless_calls = ref true in + let filter_useless_functions = ref true in + let test_units = ref false in + let test_trans_units = ref false in + let no_decreases_clauses = ref false in + let no_state = ref false in + let template_decreases_clauses = ref false in + let no_split_files = ref false in + let no_check_inv = ref false in + + let spec = + [ + ("-dest", Arg.Set_string dest_dir, " Specify the output directory"); + ( "-decompose-monads", + Arg.Set decompose_monads, + " Decompose the monadic let-bindings.\n\n\ + \ Introduces a temporary variable which is later decomposed,\n\ + \ when the pattern on the left of the monadic let is not a \n\ + \ variable.\n\ + \ \n\ + \ Example:\n\ + \ `(x, y) <-- f (); ...` ~~>\n\ + \ `tmp <-- f (); let (x, y) = tmp in ...`\n\ + \ " ); + ( "-unfold-monads", + Arg.Set unfold_monads, + " Unfold the monadic let-bindings to matches" ); + ( "-filter-useless-calls", + Arg.Set filter_useless_calls, + " Filter the useless function calls, when possible" ); + ( "-filter-useless-funs", + Arg.Set filter_useless_functions, + " Filter the useless forward/backward functions" ); + ( "-test-units", + Arg.Set test_units, + " Test the unit functions with the concrete interpreter" ); + ( "-test-trans-units", + Arg.Set test_trans_units, + " Test the translated unit functions with the target theorem\n\ + \ prover's normalizer" ); + ( "-no-decreases-clauses", + Arg.Set no_decreases_clauses, + " Do not add decrease clauses to the recursive definitions" ); + ( "-no-state", + Arg.Set no_state, + " Do not use state-error monads, simply use error monads" ); + ( "-template-clauses", + Arg.Set template_decreases_clauses, + " Generate templates for the required decreases clauses, in a\n\ + \ dedicated file. Incompatible with \ + -no-decreases-clauses" ); + ( "-no-split-files", + Arg.Set no_split_files, + " Don't split the definitions between different files for types,\n\ + \ functions, etc." ); + ( "-no-check-inv", + Arg.Set no_check_inv, + " Deactivate the invariant sanity checks performed at every step of\n\ + \ evaluation. Dramatically saves speed." ); + ] + in + (* Sanity check: -template-clauses ==> not -no-decrease-clauses *) + assert ((not !no_decreases_clauses) || not !template_decreases_clauses); + + let spec = Arg.align spec in + let filenames = ref [] in + let add_filename f = filenames := f :: !filenames in + Arg.parse spec add_filename usage; + let fail () = + print_string usage; + exit 1 + in + (* Retrieve and check the filename *) + let filename = + match !filenames with + | [ f ] -> + (* TODO: update the extension *) + if not (Filename.check_suffix f ".llbc") then ( + print_string "Unrecognized file extension"; + fail ()) + else if not (Sys.file_exists f) then ( + print_string "File not found"; + fail ()) + else f + | _ -> + (* For now, we only process one file at a time *) + print_string usage; + exit 1 + in + (* Check the destination directory *) + let dest_dir = + if !dest_dir = "" then Filename.dirname filename else !dest_dir + in + + (* Set up the logging - for now we use default values - TODO: use the + * command-line arguments *) + (* By setting a level for the main_logger_handler, we filter everything *) + Easy_logging.Handlers.set_level main_logger_handler EL.Debug; + main_log#set_level EL.Info; + llbc_of_json_logger#set_level EL.Info; + pre_passes_log#set_level EL.Info; + interpreter_log#set_level EL.Info; + statements_log#set_level EL.Info; + paths_log#set_level EL.Info; + expressions_log#set_level EL.Info; + expansion_log#set_level EL.Info; + borrows_log#set_level EL.Info; + invariants_log#set_level EL.Info; + pure_utils_log#set_level EL.Info; + symbolic_to_pure_log#set_level EL.Info; + pure_micro_passes_log#set_level EL.Info; + pure_to_extract_log#set_level EL.Info; + translate_log#set_level EL.Info; + + (* Load the module *) + let json = Yojson.Basic.from_file filename in + match llbc_crate_of_json json with + | Error s -> + main_log#error "error: %s\n" s; + exit 1 + | Ok m -> + (* Logging *) + main_log#linfo (lazy ("Imported: " ^ filename)); + main_log#ldebug (lazy ("\n" ^ Print.Module.module_to_string m ^ "\n")); + + (* Apply the pre-passes *) + let m = PrePasses.apply_passes m in + + (* Some options for the execution *) + let eval_config = + { + C.check_invariants = not !no_check_inv; + greedy_expand_symbolics_with_borrows = true; + allow_bottom_below_borrow = true; + return_unit_end_abs_with_no_loans = true; + } + in + + (* Test the unit functions with the concrete interpreter *) + if !test_units then I.Test.test_unit_functions eval_config m; + + (* Evaluate the symbolic interpreter on the functions, ignoring the + * functions which contain loops - TODO: remove *) + let synthesize = true in + I.Test.test_functions_symbolic eval_config synthesize m; + + (* Translate the functions *) + let test_unit_functions = !test_trans_units in + let micro_passes_config = + { + Micro.decompose_monadic_let_bindings = !decompose_monads; + unfold_monadic_let_bindings = !unfold_monads; + filter_useless_monadic_calls = !filter_useless_calls; + filter_useless_functions = !filter_useless_functions; + } + in + let trans_config = + { + Translate.eval_config; + mp_config = micro_passes_config; + split_files = not !no_split_files; + test_unit_functions; + extract_decreases_clauses = not !no_decreases_clauses; + extract_template_decreases_clauses = !template_decreases_clauses; + use_state = not !no_state; + } + in + Translate.translate_module filename dest_dir trans_config m; + + (* Print total elapsed time *) + log#linfo + (lazy + (Printf.sprintf "Total execution time: %f seconds" + (Unix.gettimeofday () -. start_time))) diff --git a/compiler/dune b/compiler/dune new file mode 100644 index 00000000..e8b53fc5 --- /dev/null +++ b/compiler/dune @@ -0,0 +1,48 @@ +;; core: for Core.Unix.mkdir_p + +(executable + (name driver) + (public_name aeneas_driver) + (package aeneas) + (preprocess + (pps ppx_deriving.show ppx_deriving.ord visitors.ppx)) + (libraries ppx_deriving yojson zarith easy_logging core_unix aeneas) + (modules driver)) + +(library + (name aeneas) ;; The name as used in the project + (public_name aeneas) ;; The name as revealed to the projects importing this library + (preprocess + (pps ppx_deriving.show ppx_deriving.ord visitors.ppx)) + (libraries ppx_deriving yojson zarith easy_logging core_unix) + (modules Assumed Collections ConstStrings Contexts Cps Crates Errors + Expressions ExpressionsUtils ExtractToFStar FunsAnalysis Identifiers + InterpreterBorrowsCore InterpreterBorrows InterpreterExpansion + InterpreterExpressions Interpreter InterpreterPaths InterpreterProjectors + InterpreterStatements InterpreterUtils Invariants LlbcAst LlbcAstUtils + LlbcOfJson Logging Meta Names OfJsonBasic PrePasses Print PrintPure + PureMicroPasses Pure PureToExtract PureTypeCheck PureUtils Scalars + StringUtils Substitute SymbolicAst SymbolicToPure SynthesizeSymbolic + TranslateCore Translate TypesAnalysis Types TypesUtils Utils Values + ValuesUtils)) + +(documentation + (package aeneas)) + +(env + (dev + (flags + :standard + -safe-string + -g + ;-dsource + -warn-error + -5-8-9-11-14-33-20-21-26-27-39)) + (release + (flags + :standard + -safe-string + -g + ;-dsource + -warn-error + -5-8-9-11-14-33-20-21-26-27-39))) diff --git a/compiler/dune-project b/compiler/dune-project new file mode 100644 index 00000000..f8b418f2 --- /dev/null +++ b/compiler/dune-project @@ -0,0 +1,24 @@ +(lang dune 2.8) + +(name aeneas) + +(version 0.1) + +(generate_opam_files true) + +(formatting) + +(source + (uri git+https://github.com/AeneasVerif/aeneas.git)) + +(homepage "https://github.com/AeneasVerif/aeneas") + +(bug_reports "https://github.com/AeneasVerif/aeneas/issues") + +(authors + "Son Ho" + "Jonathan Protzenko" + "Aymeric Fromherz" + "Sidney Congard") + +(license Apache-2.0) \ No newline at end of file diff --git a/compiler/fstar/Primitives.fst b/compiler/fstar/Primitives.fst new file mode 100644 index 00000000..b44fe9d1 --- /dev/null +++ b/compiler/fstar/Primitives.fst @@ -0,0 +1,286 @@ +/// This file lists primitive and assumed functions and types +module Primitives +open FStar.Mul +open FStar.List.Tot + +#set-options "--z3rlimit 15 --fuel 0 --ifuel 1" + +(*** Utilities *) +val list_update (#a : Type0) (ls : list a) (i : nat{i < length ls}) (x : a) : + ls':list a{ + length ls' = length ls /\ + index ls' i == x + } +#push-options "--fuel 1" +let rec list_update #a ls i x = + match ls with + | x' :: ls -> if i = 0 then x :: ls else x' :: list_update ls (i-1) x +#pop-options + +(*** Result *) +type result (a : Type0) : Type0 = +| Return : v:a -> result a +| Fail : result a + +// Monadic bind and return. +// Re-definining those allows us to customize the result of the monadic notations +// like: `y <-- f x;` +let return (#a : Type0) (x:a) : result a = Return x +let bind (#a #b : Type0) (m : result a) (f : a -> result b) : result b = + match m with + | Return x -> f x + | Fail -> Fail + +// Monadic assert(...) +let massert (b:bool) : result unit = if b then Return () else Fail + +// Normalize and unwrap a successful result (used for globals). +let eval_global (#a : Type0) (x : result a{Return? (normalize_term x)}) : a = Return?.v x + +(*** Misc *) +type char = FStar.Char.char +type string = string + +let mem_replace_fwd (a : Type0) (x : a) (y : a) : a = x +let mem_replace_back (a : Type0) (x : a) (y : a) : a = y + +(*** Scalars *) +/// Rk.: most of the following code was at least partially generated + +let isize_min : int = -9223372036854775808 +let isize_max : int = 9223372036854775807 +let i8_min : int = -128 +let i8_max : int = 127 +let i16_min : int = -32768 +let i16_max : int = 32767 +let i32_min : int = -2147483648 +let i32_max : int = 2147483647 +let i64_min : int = -9223372036854775808 +let i64_max : int = 9223372036854775807 +let i128_min : int = -170141183460469231731687303715884105728 +let i128_max : int = 170141183460469231731687303715884105727 +let usize_min : int = 0 +let usize_max : int = 4294967295 // being conservative here: [u32_max] instead of [u64_max] +let u8_min : int = 0 +let u8_max : int = 255 +let u16_min : int = 0 +let u16_max : int = 65535 +let u32_min : int = 0 +let u32_max : int = 4294967295 +let u64_min : int = 0 +let u64_max : int = 18446744073709551615 +let u128_min : int = 0 +let u128_max : int = 340282366920938463463374607431768211455 + +type scalar_ty = +| Isize +| I8 +| I16 +| I32 +| I64 +| I128 +| Usize +| U8 +| U16 +| U32 +| U64 +| U128 + +let scalar_min (ty : scalar_ty) : int = + match ty with + | Isize -> isize_min + | I8 -> i8_min + | I16 -> i16_min + | I32 -> i32_min + | I64 -> i64_min + | I128 -> i128_min + | Usize -> usize_min + | U8 -> u8_min + | U16 -> u16_min + | U32 -> u32_min + | U64 -> u64_min + | U128 -> u128_min + +let scalar_max (ty : scalar_ty) : int = + match ty with + | Isize -> isize_max + | I8 -> i8_max + | I16 -> i16_max + | I32 -> i32_max + | I64 -> i64_max + | I128 -> i128_max + | Usize -> usize_max + | U8 -> u8_max + | U16 -> u16_max + | U32 -> u32_max + | U64 -> u64_max + | U128 -> u128_max + +type scalar (ty : scalar_ty) : eqtype = x:int{scalar_min ty <= x && x <= scalar_max ty} + +let mk_scalar (ty : scalar_ty) (x : int) : result (scalar ty) = + if scalar_min ty <= x && scalar_max ty >= x then Return x else Fail + +let scalar_neg (#ty : scalar_ty) (x : scalar ty) : result (scalar ty) = mk_scalar ty (-x) + +let scalar_div (#ty : scalar_ty) (x : scalar ty) (y : scalar ty) : result (scalar ty) = + if y <> 0 then mk_scalar ty (x / y) else Fail + +/// The remainder operation +let int_rem (x : int) (y : int{y <> 0}) : int = + if x >= 0 then (x % y) else -(x % y) + +(* Checking consistency with Rust *) +let _ = assert_norm(int_rem 1 2 = 1) +let _ = assert_norm(int_rem (-1) 2 = -1) +let _ = assert_norm(int_rem 1 (-2) = 1) +let _ = assert_norm(int_rem (-1) (-2) = -1) + +let scalar_rem (#ty : scalar_ty) (x : scalar ty) (y : scalar ty) : result (scalar ty) = + if y <> 0 then mk_scalar ty (int_rem x y) else Fail + +let scalar_add (#ty : scalar_ty) (x : scalar ty) (y : scalar ty) : result (scalar ty) = + mk_scalar ty (x + y) + +let scalar_sub (#ty : scalar_ty) (x : scalar ty) (y : scalar ty) : result (scalar ty) = + mk_scalar ty (x - y) + +let scalar_mul (#ty : scalar_ty) (x : scalar ty) (y : scalar ty) : result (scalar ty) = + mk_scalar ty (x * y) + +(** Cast an integer from a [src_ty] to a [tgt_ty] *) +let scalar_cast (src_ty : scalar_ty) (tgt_ty : scalar_ty) (x : scalar src_ty) : result (scalar tgt_ty) = + mk_scalar tgt_ty x + +/// The scalar types +type isize : eqtype = scalar Isize +type i8 : eqtype = scalar I8 +type i16 : eqtype = scalar I16 +type i32 : eqtype = scalar I32 +type i64 : eqtype = scalar I64 +type i128 : eqtype = scalar I128 +type usize : eqtype = scalar Usize +type u8 : eqtype = scalar U8 +type u16 : eqtype = scalar U16 +type u32 : eqtype = scalar U32 +type u64 : eqtype = scalar U64 +type u128 : eqtype = scalar U128 + +/// Negation +let isize_neg = scalar_neg #Isize +let i8_neg = scalar_neg #I8 +let i16_neg = scalar_neg #I16 +let i32_neg = scalar_neg #I32 +let i64_neg = scalar_neg #I64 +let i128_neg = scalar_neg #I128 + +/// Division +let isize_div = scalar_div #Isize +let i8_div = scalar_div #I8 +let i16_div = scalar_div #I16 +let i32_div = scalar_div #I32 +let i64_div = scalar_div #I64 +let i128_div = scalar_div #I128 +let usize_div = scalar_div #Usize +let u8_div = scalar_div #U8 +let u16_div = scalar_div #U16 +let u32_div = scalar_div #U32 +let u64_div = scalar_div #U64 +let u128_div = scalar_div #U128 + +/// Remainder +let isize_rem = scalar_rem #Isize +let i8_rem = scalar_rem #I8 +let i16_rem = scalar_rem #I16 +let i32_rem = scalar_rem #I32 +let i64_rem = scalar_rem #I64 +let i128_rem = scalar_rem #I128 +let usize_rem = scalar_rem #Usize +let u8_rem = scalar_rem #U8 +let u16_rem = scalar_rem #U16 +let u32_rem = scalar_rem #U32 +let u64_rem = scalar_rem #U64 +let u128_rem = scalar_rem #U128 + +/// Addition +let isize_add = scalar_add #Isize +let i8_add = scalar_add #I8 +let i16_add = scalar_add #I16 +let i32_add = scalar_add #I32 +let i64_add = scalar_add #I64 +let i128_add = scalar_add #I128 +let usize_add = scalar_add #Usize +let u8_add = scalar_add #U8 +let u16_add = scalar_add #U16 +let u32_add = scalar_add #U32 +let u64_add = scalar_add #U64 +let u128_add = scalar_add #U128 + +/// Substraction +let isize_sub = scalar_sub #Isize +let i8_sub = scalar_sub #I8 +let i16_sub = scalar_sub #I16 +let i32_sub = scalar_sub #I32 +let i64_sub = scalar_sub #I64 +let i128_sub = scalar_sub #I128 +let usize_sub = scalar_sub #Usize +let u8_sub = scalar_sub #U8 +let u16_sub = scalar_sub #U16 +let u32_sub = scalar_sub #U32 +let u64_sub = scalar_sub #U64 +let u128_sub = scalar_sub #U128 + +/// Multiplication +let isize_mul = scalar_mul #Isize +let i8_mul = scalar_mul #I8 +let i16_mul = scalar_mul #I16 +let i32_mul = scalar_mul #I32 +let i64_mul = scalar_mul #I64 +let i128_mul = scalar_mul #I128 +let usize_mul = scalar_mul #Usize +let u8_mul = scalar_mul #U8 +let u16_mul = scalar_mul #U16 +let u32_mul = scalar_mul #U32 +let u64_mul = scalar_mul #U64 +let u128_mul = scalar_mul #U128 + +(*** Vector *) +type vec (a : Type0) = v:list a{length v <= usize_max} + +let vec_new (a : Type0) : vec a = assert_norm(length #a [] == 0); [] +let vec_len (a : Type0) (v : vec a) : usize = length v + +// The **forward** function shouldn't be used +let vec_push_fwd (a : Type0) (v : vec a) (x : a) : unit = () +let vec_push_back (a : Type0) (v : vec a) (x : a) : + Pure (result (vec a)) + (requires True) + (ensures (fun res -> + match res with + | Fail -> True + | Return v' -> length v' = length v + 1)) = + if length v < usize_max then begin + (**) assert_norm(length [x] == 1); + (**) append_length v [x]; + (**) assert(length (append v [x]) = length v + 1); + Return (append v [x]) + end + else Fail + +// The **forward** function shouldn't be used +let vec_insert_fwd (a : Type0) (v : vec a) (i : usize) (x : a) : result unit = + if i < length v then Return () else Fail +let vec_insert_back (a : Type0) (v : vec a) (i : usize) (x : a) : result (vec a) = + if i < length v then Return (list_update v i x) else Fail + +// The **backward** function shouldn't be used +let vec_index_fwd (a : Type0) (v : vec a) (i : usize) : result a = + if i < length v then Return (index v i) else Fail +let vec_index_back (a : Type0) (v : vec a) (i : usize) (x : a) : result unit = + if i < length v then Return () else Fail + +let vec_index_mut_fwd (a : Type0) (v : vec a) (i : usize) : result a = + if i < length v then Return (index v i) else Fail +let vec_index_mut_back (a : Type0) (v : vec a) (i : usize) (nx : a) : result (vec a) = + if i < length v then Return (list_update v i nx) else Fail + diff --git a/dune-project b/dune-project deleted file mode 100644 index f8b418f2..00000000 --- a/dune-project +++ /dev/null @@ -1,24 +0,0 @@ -(lang dune 2.8) - -(name aeneas) - -(version 0.1) - -(generate_opam_files true) - -(formatting) - -(source - (uri git+https://github.com/AeneasVerif/aeneas.git)) - -(homepage "https://github.com/AeneasVerif/aeneas") - -(bug_reports "https://github.com/AeneasVerif/aeneas/issues") - -(authors - "Son Ho" - "Jonathan Protzenko" - "Aymeric Fromherz" - "Sidney Congard") - -(license Apache-2.0) \ No newline at end of file diff --git a/fstar/Primitives.fst b/fstar/Primitives.fst deleted file mode 100644 index b44fe9d1..00000000 --- a/fstar/Primitives.fst +++ /dev/null @@ -1,286 +0,0 @@ -/// This file lists primitive and assumed functions and types -module Primitives -open FStar.Mul -open FStar.List.Tot - -#set-options "--z3rlimit 15 --fuel 0 --ifuel 1" - -(*** Utilities *) -val list_update (#a : Type0) (ls : list a) (i : nat{i < length ls}) (x : a) : - ls':list a{ - length ls' = length ls /\ - index ls' i == x - } -#push-options "--fuel 1" -let rec list_update #a ls i x = - match ls with - | x' :: ls -> if i = 0 then x :: ls else x' :: list_update ls (i-1) x -#pop-options - -(*** Result *) -type result (a : Type0) : Type0 = -| Return : v:a -> result a -| Fail : result a - -// Monadic bind and return. -// Re-definining those allows us to customize the result of the monadic notations -// like: `y <-- f x;` -let return (#a : Type0) (x:a) : result a = Return x -let bind (#a #b : Type0) (m : result a) (f : a -> result b) : result b = - match m with - | Return x -> f x - | Fail -> Fail - -// Monadic assert(...) -let massert (b:bool) : result unit = if b then Return () else Fail - -// Normalize and unwrap a successful result (used for globals). -let eval_global (#a : Type0) (x : result a{Return? (normalize_term x)}) : a = Return?.v x - -(*** Misc *) -type char = FStar.Char.char -type string = string - -let mem_replace_fwd (a : Type0) (x : a) (y : a) : a = x -let mem_replace_back (a : Type0) (x : a) (y : a) : a = y - -(*** Scalars *) -/// Rk.: most of the following code was at least partially generated - -let isize_min : int = -9223372036854775808 -let isize_max : int = 9223372036854775807 -let i8_min : int = -128 -let i8_max : int = 127 -let i16_min : int = -32768 -let i16_max : int = 32767 -let i32_min : int = -2147483648 -let i32_max : int = 2147483647 -let i64_min : int = -9223372036854775808 -let i64_max : int = 9223372036854775807 -let i128_min : int = -170141183460469231731687303715884105728 -let i128_max : int = 170141183460469231731687303715884105727 -let usize_min : int = 0 -let usize_max : int = 4294967295 // being conservative here: [u32_max] instead of [u64_max] -let u8_min : int = 0 -let u8_max : int = 255 -let u16_min : int = 0 -let u16_max : int = 65535 -let u32_min : int = 0 -let u32_max : int = 4294967295 -let u64_min : int = 0 -let u64_max : int = 18446744073709551615 -let u128_min : int = 0 -let u128_max : int = 340282366920938463463374607431768211455 - -type scalar_ty = -| Isize -| I8 -| I16 -| I32 -| I64 -| I128 -| Usize -| U8 -| U16 -| U32 -| U64 -| U128 - -let scalar_min (ty : scalar_ty) : int = - match ty with - | Isize -> isize_min - | I8 -> i8_min - | I16 -> i16_min - | I32 -> i32_min - | I64 -> i64_min - | I128 -> i128_min - | Usize -> usize_min - | U8 -> u8_min - | U16 -> u16_min - | U32 -> u32_min - | U64 -> u64_min - | U128 -> u128_min - -let scalar_max (ty : scalar_ty) : int = - match ty with - | Isize -> isize_max - | I8 -> i8_max - | I16 -> i16_max - | I32 -> i32_max - | I64 -> i64_max - | I128 -> i128_max - | Usize -> usize_max - | U8 -> u8_max - | U16 -> u16_max - | U32 -> u32_max - | U64 -> u64_max - | U128 -> u128_max - -type scalar (ty : scalar_ty) : eqtype = x:int{scalar_min ty <= x && x <= scalar_max ty} - -let mk_scalar (ty : scalar_ty) (x : int) : result (scalar ty) = - if scalar_min ty <= x && scalar_max ty >= x then Return x else Fail - -let scalar_neg (#ty : scalar_ty) (x : scalar ty) : result (scalar ty) = mk_scalar ty (-x) - -let scalar_div (#ty : scalar_ty) (x : scalar ty) (y : scalar ty) : result (scalar ty) = - if y <> 0 then mk_scalar ty (x / y) else Fail - -/// The remainder operation -let int_rem (x : int) (y : int{y <> 0}) : int = - if x >= 0 then (x % y) else -(x % y) - -(* Checking consistency with Rust *) -let _ = assert_norm(int_rem 1 2 = 1) -let _ = assert_norm(int_rem (-1) 2 = -1) -let _ = assert_norm(int_rem 1 (-2) = 1) -let _ = assert_norm(int_rem (-1) (-2) = -1) - -let scalar_rem (#ty : scalar_ty) (x : scalar ty) (y : scalar ty) : result (scalar ty) = - if y <> 0 then mk_scalar ty (int_rem x y) else Fail - -let scalar_add (#ty : scalar_ty) (x : scalar ty) (y : scalar ty) : result (scalar ty) = - mk_scalar ty (x + y) - -let scalar_sub (#ty : scalar_ty) (x : scalar ty) (y : scalar ty) : result (scalar ty) = - mk_scalar ty (x - y) - -let scalar_mul (#ty : scalar_ty) (x : scalar ty) (y : scalar ty) : result (scalar ty) = - mk_scalar ty (x * y) - -(** Cast an integer from a [src_ty] to a [tgt_ty] *) -let scalar_cast (src_ty : scalar_ty) (tgt_ty : scalar_ty) (x : scalar src_ty) : result (scalar tgt_ty) = - mk_scalar tgt_ty x - -/// The scalar types -type isize : eqtype = scalar Isize -type i8 : eqtype = scalar I8 -type i16 : eqtype = scalar I16 -type i32 : eqtype = scalar I32 -type i64 : eqtype = scalar I64 -type i128 : eqtype = scalar I128 -type usize : eqtype = scalar Usize -type u8 : eqtype = scalar U8 -type u16 : eqtype = scalar U16 -type u32 : eqtype = scalar U32 -type u64 : eqtype = scalar U64 -type u128 : eqtype = scalar U128 - -/// Negation -let isize_neg = scalar_neg #Isize -let i8_neg = scalar_neg #I8 -let i16_neg = scalar_neg #I16 -let i32_neg = scalar_neg #I32 -let i64_neg = scalar_neg #I64 -let i128_neg = scalar_neg #I128 - -/// Division -let isize_div = scalar_div #Isize -let i8_div = scalar_div #I8 -let i16_div = scalar_div #I16 -let i32_div = scalar_div #I32 -let i64_div = scalar_div #I64 -let i128_div = scalar_div #I128 -let usize_div = scalar_div #Usize -let u8_div = scalar_div #U8 -let u16_div = scalar_div #U16 -let u32_div = scalar_div #U32 -let u64_div = scalar_div #U64 -let u128_div = scalar_div #U128 - -/// Remainder -let isize_rem = scalar_rem #Isize -let i8_rem = scalar_rem #I8 -let i16_rem = scalar_rem #I16 -let i32_rem = scalar_rem #I32 -let i64_rem = scalar_rem #I64 -let i128_rem = scalar_rem #I128 -let usize_rem = scalar_rem #Usize -let u8_rem = scalar_rem #U8 -let u16_rem = scalar_rem #U16 -let u32_rem = scalar_rem #U32 -let u64_rem = scalar_rem #U64 -let u128_rem = scalar_rem #U128 - -/// Addition -let isize_add = scalar_add #Isize -let i8_add = scalar_add #I8 -let i16_add = scalar_add #I16 -let i32_add = scalar_add #I32 -let i64_add = scalar_add #I64 -let i128_add = scalar_add #I128 -let usize_add = scalar_add #Usize -let u8_add = scalar_add #U8 -let u16_add = scalar_add #U16 -let u32_add = scalar_add #U32 -let u64_add = scalar_add #U64 -let u128_add = scalar_add #U128 - -/// Substraction -let isize_sub = scalar_sub #Isize -let i8_sub = scalar_sub #I8 -let i16_sub = scalar_sub #I16 -let i32_sub = scalar_sub #I32 -let i64_sub = scalar_sub #I64 -let i128_sub = scalar_sub #I128 -let usize_sub = scalar_sub #Usize -let u8_sub = scalar_sub #U8 -let u16_sub = scalar_sub #U16 -let u32_sub = scalar_sub #U32 -let u64_sub = scalar_sub #U64 -let u128_sub = scalar_sub #U128 - -/// Multiplication -let isize_mul = scalar_mul #Isize -let i8_mul = scalar_mul #I8 -let i16_mul = scalar_mul #I16 -let i32_mul = scalar_mul #I32 -let i64_mul = scalar_mul #I64 -let i128_mul = scalar_mul #I128 -let usize_mul = scalar_mul #Usize -let u8_mul = scalar_mul #U8 -let u16_mul = scalar_mul #U16 -let u32_mul = scalar_mul #U32 -let u64_mul = scalar_mul #U64 -let u128_mul = scalar_mul #U128 - -(*** Vector *) -type vec (a : Type0) = v:list a{length v <= usize_max} - -let vec_new (a : Type0) : vec a = assert_norm(length #a [] == 0); [] -let vec_len (a : Type0) (v : vec a) : usize = length v - -// The **forward** function shouldn't be used -let vec_push_fwd (a : Type0) (v : vec a) (x : a) : unit = () -let vec_push_back (a : Type0) (v : vec a) (x : a) : - Pure (result (vec a)) - (requires True) - (ensures (fun res -> - match res with - | Fail -> True - | Return v' -> length v' = length v + 1)) = - if length v < usize_max then begin - (**) assert_norm(length [x] == 1); - (**) append_length v [x]; - (**) assert(length (append v [x]) = length v + 1); - Return (append v [x]) - end - else Fail - -// The **forward** function shouldn't be used -let vec_insert_fwd (a : Type0) (v : vec a) (i : usize) (x : a) : result unit = - if i < length v then Return () else Fail -let vec_insert_back (a : Type0) (v : vec a) (i : usize) (x : a) : result (vec a) = - if i < length v then Return (list_update v i x) else Fail - -// The **backward** function shouldn't be used -let vec_index_fwd (a : Type0) (v : vec a) (i : usize) : result a = - if i < length v then Return (index v i) else Fail -let vec_index_back (a : Type0) (v : vec a) (i : usize) (x : a) : result unit = - if i < length v then Return () else Fail - -let vec_index_mut_fwd (a : Type0) (v : vec a) (i : usize) : result a = - if i < length v then Return (index v i) else Fail -let vec_index_mut_back (a : Type0) (v : vec a) (i : usize) (nx : a) : result (vec a) = - if i < length v then Return (list_update v i nx) else Fail - diff --git a/rust-scripts/Cargo.toml b/rust-scripts/Cargo.toml new file mode 100644 index 00000000..31ef5be0 --- /dev/null +++ b/rust-scripts/Cargo.toml @@ -0,0 +1,7 @@ +[package] +name = "rust-tests" +version = "0.1.0" +authors = ["Son Ho "] +edition = "2018" + +[dependencies] \ No newline at end of file diff --git a/rust-scripts/src/main.rs b/rust-scripts/src/main.rs new file mode 100644 index 00000000..125b0d76 --- /dev/null +++ b/rust-scripts/src/main.rs @@ -0,0 +1,150 @@ +/// The following code generates the limits for the scalar types + +fn test_modulo(x: i32, y: i32) { + println!("{} % {} = {}", x, y, x % y); +} + +fn main() { + let ints_lower = [ + "isize", "i8", "i16", "i32", "i64", "i128", "usize", "u8", "u16", "u32", "u64", "u128", + ]; + + let ints_upper = [ + "Isize", "I8", "I16", "I32", "I64", "I128", "Usize", "U8", "U16", "U32", "U64", "U128", + ]; + + let can_fail_binops_lower = ["div", "rem", "add", "sub", "mul"]; + + let mut ints_pairs = vec![]; + for i in 0..ints_lower.len() { + ints_pairs.push((&ints_lower[i], &ints_upper[i])); + } + + // Generate the code to print the scalar ranges + for s in &ints_lower { + println!( + "println!(\"let {}_min = Z.of_string \\\"{{}}\\\"\", {}::MIN);", + s, s + ); + println!( + "println!(\"let {}_max = Z.of_string \\\"{{}}\\\"\", {}::MAX);", + s, s + ); + } + println!("\n"); + + // Generate the OCaml definitions for the ranges - this code is + // generated (comes from the above) + println!("let isize_min = Z.of_string \"{}\"", isize::MIN); + println!("let isize_max = Z.of_string \"{}\"", isize::MAX); + println!("let i8_min = Z.of_string \"{}\"", i8::MIN); + println!("let i8_max = Z.of_string \"{}\"", i8::MAX); + println!("let i16_min = Z.of_string \"{}\"", i16::MIN); + println!("let i16_max = Z.of_string \"{}\"", i16::MAX); + println!("let i32_min = Z.of_string \"{}\"", i32::MIN); + println!("let i32_max = Z.of_string \"{}\"", i32::MAX); + println!("let i64_min = Z.of_string \"{}\"", i64::MIN); + println!("let i64_max = Z.of_string \"{}\"", i64::MAX); + println!("let i128_min = Z.of_string \"{}\"", i128::MIN); + println!("let i128_max = Z.of_string \"{}\"", i128::MAX); + println!("let usize_min = Z.of_string \"{}\"", usize::MIN); + println!("let usize_max = Z.of_string \"{}\"", usize::MAX); + println!("let u8_min = Z.of_string \"{}\"", u8::MIN); + println!("let u8_max = Z.of_string \"{}\"", u8::MAX); + println!("let u16_min = Z.of_string \"{}\"", u16::MIN); + println!("let u16_max = Z.of_string \"{}\"", u16::MAX); + println!("let u32_min = Z.of_string \"{}\"", u32::MIN); + println!("let u32_max = Z.of_string \"{}\"", u32::MAX); + println!("let u64_min = Z.of_string \"{}\"", u64::MIN); + println!("let u64_max = Z.of_string \"{}\"", u64::MAX); + println!("let u128_min = Z.of_string \"{}\"", u128::MIN); + println!("let u128_max = Z.of_string \"{}\"", u128::MAX); + println!("\n"); + + // Generate the check_int_in_range body + for (lo, up) in &ints_pairs { + println!("| {} -> Z.leq {}_min i && Z.leq i {}_max", up, lo, lo); + } + println!("\n"); + + // Generate the scalar_value_get_value_range body + for s in &ints_upper { + println!("| {} i -> i", s); + } + println!("\n"); + + // Generate the mk_scalar body + for s in &ints_upper { + println!("| Types.{} -> Ok ({} i)", s, s); + } + println!("\n"); + + // Generate the code to print the scalar ranges in F* + for s in &ints_lower { + println!("println!(\"let {}_min : int = {{}}\", {}::MIN);", s, s); + println!("println!(\"let {}_max : int = {{}}\", {}::MAX);", s, s); + } + println!("\n"); + + // Generate the F* definitions for the ranges - this code is + // generated (comes from the above) + println!("let isize_min : int = {}", isize::MIN); + println!("let isize_max : int = {}", isize::MAX); + println!("let i8_min : int = {}", i8::MIN); + println!("let i8_max : int = {}", i8::MAX); + println!("let i16_min : int = {}", i16::MIN); + println!("let i16_max : int = {}", i16::MAX); + println!("let i32_min : int = {}", i32::MIN); + println!("let i32_max : int = {}", i32::MAX); + println!("let i64_min : int = {}", i64::MIN); + println!("let i64_max : int = {}", i64::MAX); + println!("let i128_min : int = {}", i128::MIN); + println!("let i128_max : int = {}", i128::MAX); + println!("let usize_min : int = {}", usize::MIN); + println!("let usize_max : int = {}", usize::MAX); + println!("let u8_min : int = {}", u8::MIN); + println!("let u8_max : int = {}", u8::MAX); + println!("let u16_min : int = {}", u16::MIN); + println!("let u16_max : int = {}", u16::MAX); + println!("let u32_min : int = {}", u32::MIN); + println!("let u32_max : int = {}", u32::MAX); + println!("let u64_min : int = {}", u64::MIN); + println!("let u64_max : int = {}", u64::MAX); + println!("let u128_min : int = {}", u128::MIN); + println!("let u128_max : int = {}", u128::MAX); + println!("\n"); + + // Generate the body for the ScalarTy definition + for (_lo, up) in &ints_pairs { + println!("| {}", up); + } + println!("\n"); + + // Generate the body for the max/min F* functions + for (lo, up) in &ints_pairs { + println!("| {} -> {}_min", up, lo); + } + println!("\n"); + + // Generate the scalar types for F* + for (lo, up) in &ints_pairs { + println!("type {} = scalar {}", lo, up); + } + println!("\n"); + + // Generate the unops (rk.: we need to manually filter `-` applied on + // unisgned numbers) + for binop in &can_fail_binops_lower { + for (lo, up) in &ints_pairs { + println!("let {}_{} = scalar_{} #{}", lo, binop, binop, up); + } + println!(""); + } + println!("\n"); + + // Modulo tests + test_modulo(1, 2); + test_modulo(-1, 2); + test_modulo(1, -2); + test_modulo(-1, -2); +} diff --git a/rust-tests/Cargo.toml b/rust-tests/Cargo.toml deleted file mode 100644 index e384da1d..00000000 --- a/rust-tests/Cargo.toml +++ /dev/null @@ -1,9 +0,0 @@ -[package] -name = "rust-tests" -version = "0.1.0" -authors = ["Son Ho "] -edition = "2018" - -# See more keys and their definitions at https://doc.rust-lang.org/cargo/reference/manifest.html - -[dependencies] diff --git a/rust-tests/src/main.rs b/rust-tests/src/main.rs deleted file mode 100644 index 125b0d76..00000000 --- a/rust-tests/src/main.rs +++ /dev/null @@ -1,150 +0,0 @@ -/// The following code generates the limits for the scalar types - -fn test_modulo(x: i32, y: i32) { - println!("{} % {} = {}", x, y, x % y); -} - -fn main() { - let ints_lower = [ - "isize", "i8", "i16", "i32", "i64", "i128", "usize", "u8", "u16", "u32", "u64", "u128", - ]; - - let ints_upper = [ - "Isize", "I8", "I16", "I32", "I64", "I128", "Usize", "U8", "U16", "U32", "U64", "U128", - ]; - - let can_fail_binops_lower = ["div", "rem", "add", "sub", "mul"]; - - let mut ints_pairs = vec![]; - for i in 0..ints_lower.len() { - ints_pairs.push((&ints_lower[i], &ints_upper[i])); - } - - // Generate the code to print the scalar ranges - for s in &ints_lower { - println!( - "println!(\"let {}_min = Z.of_string \\\"{{}}\\\"\", {}::MIN);", - s, s - ); - println!( - "println!(\"let {}_max = Z.of_string \\\"{{}}\\\"\", {}::MAX);", - s, s - ); - } - println!("\n"); - - // Generate the OCaml definitions for the ranges - this code is - // generated (comes from the above) - println!("let isize_min = Z.of_string \"{}\"", isize::MIN); - println!("let isize_max = Z.of_string \"{}\"", isize::MAX); - println!("let i8_min = Z.of_string \"{}\"", i8::MIN); - println!("let i8_max = Z.of_string \"{}\"", i8::MAX); - println!("let i16_min = Z.of_string \"{}\"", i16::MIN); - println!("let i16_max = Z.of_string \"{}\"", i16::MAX); - println!("let i32_min = Z.of_string \"{}\"", i32::MIN); - println!("let i32_max = Z.of_string \"{}\"", i32::MAX); - println!("let i64_min = Z.of_string \"{}\"", i64::MIN); - println!("let i64_max = Z.of_string \"{}\"", i64::MAX); - println!("let i128_min = Z.of_string \"{}\"", i128::MIN); - println!("let i128_max = Z.of_string \"{}\"", i128::MAX); - println!("let usize_min = Z.of_string \"{}\"", usize::MIN); - println!("let usize_max = Z.of_string \"{}\"", usize::MAX); - println!("let u8_min = Z.of_string \"{}\"", u8::MIN); - println!("let u8_max = Z.of_string \"{}\"", u8::MAX); - println!("let u16_min = Z.of_string \"{}\"", u16::MIN); - println!("let u16_max = Z.of_string \"{}\"", u16::MAX); - println!("let u32_min = Z.of_string \"{}\"", u32::MIN); - println!("let u32_max = Z.of_string \"{}\"", u32::MAX); - println!("let u64_min = Z.of_string \"{}\"", u64::MIN); - println!("let u64_max = Z.of_string \"{}\"", u64::MAX); - println!("let u128_min = Z.of_string \"{}\"", u128::MIN); - println!("let u128_max = Z.of_string \"{}\"", u128::MAX); - println!("\n"); - - // Generate the check_int_in_range body - for (lo, up) in &ints_pairs { - println!("| {} -> Z.leq {}_min i && Z.leq i {}_max", up, lo, lo); - } - println!("\n"); - - // Generate the scalar_value_get_value_range body - for s in &ints_upper { - println!("| {} i -> i", s); - } - println!("\n"); - - // Generate the mk_scalar body - for s in &ints_upper { - println!("| Types.{} -> Ok ({} i)", s, s); - } - println!("\n"); - - // Generate the code to print the scalar ranges in F* - for s in &ints_lower { - println!("println!(\"let {}_min : int = {{}}\", {}::MIN);", s, s); - println!("println!(\"let {}_max : int = {{}}\", {}::MAX);", s, s); - } - println!("\n"); - - // Generate the F* definitions for the ranges - this code is - // generated (comes from the above) - println!("let isize_min : int = {}", isize::MIN); - println!("let isize_max : int = {}", isize::MAX); - println!("let i8_min : int = {}", i8::MIN); - println!("let i8_max : int = {}", i8::MAX); - println!("let i16_min : int = {}", i16::MIN); - println!("let i16_max : int = {}", i16::MAX); - println!("let i32_min : int = {}", i32::MIN); - println!("let i32_max : int = {}", i32::MAX); - println!("let i64_min : int = {}", i64::MIN); - println!("let i64_max : int = {}", i64::MAX); - println!("let i128_min : int = {}", i128::MIN); - println!("let i128_max : int = {}", i128::MAX); - println!("let usize_min : int = {}", usize::MIN); - println!("let usize_max : int = {}", usize::MAX); - println!("let u8_min : int = {}", u8::MIN); - println!("let u8_max : int = {}", u8::MAX); - println!("let u16_min : int = {}", u16::MIN); - println!("let u16_max : int = {}", u16::MAX); - println!("let u32_min : int = {}", u32::MIN); - println!("let u32_max : int = {}", u32::MAX); - println!("let u64_min : int = {}", u64::MIN); - println!("let u64_max : int = {}", u64::MAX); - println!("let u128_min : int = {}", u128::MIN); - println!("let u128_max : int = {}", u128::MAX); - println!("\n"); - - // Generate the body for the ScalarTy definition - for (_lo, up) in &ints_pairs { - println!("| {}", up); - } - println!("\n"); - - // Generate the body for the max/min F* functions - for (lo, up) in &ints_pairs { - println!("| {} -> {}_min", up, lo); - } - println!("\n"); - - // Generate the scalar types for F* - for (lo, up) in &ints_pairs { - println!("type {} = scalar {}", lo, up); - } - println!("\n"); - - // Generate the unops (rk.: we need to manually filter `-` applied on - // unisgned numbers) - for binop in &can_fail_binops_lower { - for (lo, up) in &ints_pairs { - println!("let {}_{} = scalar_{} #{}", lo, binop, binop, up); - } - println!(""); - } - println!("\n"); - - // Modulo tests - test_modulo(1, 2); - test_modulo(-1, 2); - test_modulo(1, -2); - test_modulo(-1, -2); -} diff --git a/src/.ocamlformat b/src/.ocamlformat deleted file mode 100644 index b0ae150e..00000000 --- a/src/.ocamlformat +++ /dev/null @@ -1 +0,0 @@ -doc-comments=before \ No newline at end of file diff --git a/src/Assumed.ml b/src/Assumed.ml deleted file mode 100644 index cb089c08..00000000 --- a/src/Assumed.ml +++ /dev/null @@ -1,300 +0,0 @@ -(** This module contains various utilities for the assumed functions. - - Note that [Box::free] is peculiar: we don't really handle it as a function, - because it is legal to free a box whose boxed value is [⊥] (it often - happens that we move a value out of a box before freeing this box). - Semantically speaking, we thus handle [Box::free] as a value drop and - not as a function call, and thus never need its signature. - - TODO: implementing the concrete evaluation functions for the assumed - functions is really annoying (see - [InterpreterStatements.eval_non_local_function_call_concrete]). - I think it should be possible, in most situations, to write bodies which - model the behaviour of those unsafe functions. For instance, [Box::deref_mut] - should simply be: - {[ - fn deref_mut<'a, T>(x : &'a mut Box) -> &'a mut T { - &mut ( *x ) // box dereferencement is a primitive operation - } - ]} - - For vectors, we could "cheat" by using the index as a field index (vectors - would be encoded as ADTs with a variable number of fields). Of course, it - would require a bit of engineering, but it would probably be quite lightweight - in the end. - {[ - Vec::get_mut<'a,T>(v : &'a mut Vec, i : usize) -> &'a mut T { - &mut ( ( *x ).i ) - } - ]} - *) - -open Names -open TypesUtils -module T = Types -module A = LlbcAst - -module Sig = struct - (** A few utilities *) - - let rvar_id_0 = T.RegionVarId.of_int 0 - let rvar_0 : T.RegionVarId.id T.region = T.Var rvar_id_0 - let rg_id_0 = T.RegionGroupId.of_int 0 - let tvar_id_0 = T.TypeVarId.of_int 0 - let tvar_0 : T.sty = T.TypeVar tvar_id_0 - - (** Region 'a of id 0 *) - let region_param_0 : T.region_var = { T.index = rvar_id_0; name = Some "'a" } - - (** Region group: [{ parent={}; regions:{'a of id 0} }] *) - let region_group_0 : T.region_var_group = - { T.id = rg_id_0; regions = [ rvar_id_0 ]; parents = [] } - - (** Type parameter [T] of id 0 *) - let type_param_0 : T.type_var = { T.index = tvar_id_0; name = "T" } - - let mk_ref_ty (r : T.RegionVarId.id T.region) (ty : T.sty) (is_mut : bool) : - T.sty = - let ref_kind = if is_mut then T.Mut else T.Shared in - mk_ref_ty r ty ref_kind - - (** [fn(&'a mut T, T) -> T] *) - let mem_replace_sig : A.fun_sig = - (* The signature fields *) - let region_params = [ region_param_0 ] (* <'a> *) in - let regions_hierarchy = [ region_group_0 ] (* [{<'a>}] *) in - let type_params = [ type_param_0 ] (* *) in - let inputs = - [ mk_ref_ty rvar_0 tvar_0 true (* &'a mut T *); tvar_0 (* T *) ] - in - let output = tvar_0 (* T *) in - { - region_params; - num_early_bound_regions = 0; - regions_hierarchy; - type_params; - inputs; - output; - } - - (** [fn(T) -> Box] *) - let box_new_sig : A.fun_sig = - { - region_params = []; - num_early_bound_regions = 0; - regions_hierarchy = []; - type_params = [ type_param_0 ] (* *); - inputs = [ tvar_0 (* T *) ]; - output = mk_box_ty tvar_0 (* Box *); - } - - (** [fn(Box) -> ()] *) - let box_free_sig : A.fun_sig = - { - region_params = []; - num_early_bound_regions = 0; - regions_hierarchy = []; - type_params = [ type_param_0 ] (* *); - inputs = [ mk_box_ty tvar_0 (* Box *) ]; - output = mk_unit_ty (* () *); - } - - (** Helper for [Box::deref_shared] and [Box::deref_mut]. - Returns: - [fn<'a, T>(&'a (mut) Box) -> &'a (mut) T] - *) - let box_deref_gen_sig (is_mut : bool) : A.fun_sig = - (* The signature fields *) - let region_params = [ region_param_0 ] in - let regions_hierarchy = [ region_group_0 ] (* <'a> *) in - { - region_params; - num_early_bound_regions = 0; - regions_hierarchy; - type_params = [ type_param_0 ] (* *); - inputs = - [ mk_ref_ty rvar_0 (mk_box_ty tvar_0) is_mut (* &'a (mut) Box *) ]; - output = mk_ref_ty rvar_0 tvar_0 is_mut (* &'a (mut) T *); - } - - (** [fn<'a, T>(&'a Box) -> &'a T] *) - let box_deref_shared_sig = box_deref_gen_sig false - - (** [fn<'a, T>(&'a mut Box) -> &'a mut T] *) - let box_deref_mut_sig = box_deref_gen_sig true - - (** [fn() -> Vec] *) - let vec_new_sig : A.fun_sig = - let region_params = [] in - let regions_hierarchy = [] in - let type_params = [ type_param_0 ] (* *) in - let inputs = [] in - let output = mk_vec_ty tvar_0 (* Vec *) in - { - region_params; - num_early_bound_regions = 0; - regions_hierarchy; - type_params; - inputs; - output; - } - - (** [fn(&'a mut Vec, T)] *) - let vec_push_sig : A.fun_sig = - (* The signature fields *) - let region_params = [ region_param_0 ] in - let regions_hierarchy = [ region_group_0 ] (* <'a> *) in - let type_params = [ type_param_0 ] (* *) in - let inputs = - [ - mk_ref_ty rvar_0 (mk_vec_ty tvar_0) true (* &'a mut Vec *); - tvar_0 (* T *); - ] - in - let output = mk_unit_ty (* () *) in - { - region_params; - num_early_bound_regions = 0; - regions_hierarchy; - type_params; - inputs; - output; - } - - (** [fn(&'a mut Vec, usize, T)] *) - let vec_insert_sig : A.fun_sig = - (* The signature fields *) - let region_params = [ region_param_0 ] in - let regions_hierarchy = [ region_group_0 ] (* <'a> *) in - let type_params = [ type_param_0 ] (* *) in - let inputs = - [ - mk_ref_ty rvar_0 (mk_vec_ty tvar_0) true (* &'a mut Vec *); - mk_usize_ty (* usize *); - tvar_0 (* T *); - ] - in - let output = mk_unit_ty (* () *) in - { - region_params; - num_early_bound_regions = 0; - regions_hierarchy; - type_params; - inputs; - output; - } - - (** [fn(&'a Vec) -> usize] *) - let vec_len_sig : A.fun_sig = - (* The signature fields *) - let region_params = [ region_param_0 ] in - let regions_hierarchy = [ region_group_0 ] (* <'a> *) in - let type_params = [ type_param_0 ] (* *) in - let inputs = - [ mk_ref_ty rvar_0 (mk_vec_ty tvar_0) false (* &'a Vec *) ] - in - let output = mk_usize_ty (* usize *) in - { - region_params; - num_early_bound_regions = 0; - regions_hierarchy; - type_params; - inputs; - output; - } - - (** Helper: - [fn(&'a (mut) Vec, usize) -> &'a (mut) T] - *) - let vec_index_gen_sig (is_mut : bool) : A.fun_sig = - (* The signature fields *) - let region_params = [ region_param_0 ] in - let regions_hierarchy = [ region_group_0 ] (* <'a> *) in - let type_params = [ type_param_0 ] (* *) in - let inputs = - [ - mk_ref_ty rvar_0 (mk_vec_ty tvar_0) is_mut (* &'a (mut) Vec *); - mk_usize_ty (* usize *); - ] - in - let output = mk_ref_ty rvar_0 tvar_0 is_mut (* &'a (mut) T *) in - { - region_params; - num_early_bound_regions = 0; - regions_hierarchy; - type_params; - inputs; - output; - } - - (** [fn(&'a Vec, usize) -> &'a T] *) - let vec_index_shared_sig : A.fun_sig = vec_index_gen_sig false - - (** [fn(&'a mut Vec, usize) -> &'a mut T] *) - let vec_index_mut_sig : A.fun_sig = vec_index_gen_sig true -end - -type assumed_info = A.assumed_fun_id * A.fun_sig * bool * name - -(** The list of assumed functions and all their information: - - their signature - - a boolean indicating whether the function can fail or not - - their name - - Rk.: following what is written above, we don't include [Box::free]. - - Remark about the vector functions: for [Vec::len] to be correct and return - a [usize], we have to make sure that vectors are bounded by the max usize. - Followingly, [Vec::push] is monadic. - *) -let assumed_infos : assumed_info list = - let deref_pre = [ "core"; "ops"; "deref" ] in - let vec_pre = [ "alloc"; "vec"; "Vec" ] in - let index_pre = [ "core"; "ops"; "index" ] in - [ - (A.Replace, Sig.mem_replace_sig, false, to_name [ "core"; "mem"; "replace" ]); - (BoxNew, Sig.box_new_sig, false, to_name [ "alloc"; "boxed"; "Box"; "new" ]); - ( BoxFree, - Sig.box_free_sig, - false, - to_name [ "alloc"; "boxed"; "Box"; "free" ] ); - ( BoxDeref, - Sig.box_deref_shared_sig, - false, - to_name (deref_pre @ [ "Deref"; "deref" ]) ); - ( BoxDerefMut, - Sig.box_deref_mut_sig, - false, - to_name (deref_pre @ [ "DerefMut"; "deref_mut" ]) ); - (VecNew, Sig.vec_new_sig, false, to_name (vec_pre @ [ "new" ])); - (VecPush, Sig.vec_push_sig, true, to_name (vec_pre @ [ "push" ])); - (VecInsert, Sig.vec_insert_sig, true, to_name (vec_pre @ [ "insert" ])); - (VecLen, Sig.vec_len_sig, false, to_name (vec_pre @ [ "len" ])); - ( VecIndex, - Sig.vec_index_shared_sig, - true, - to_name (index_pre @ [ "Index"; "index" ]) ); - ( VecIndexMut, - Sig.vec_index_mut_sig, - true, - to_name (index_pre @ [ "IndexMut"; "index_mut" ]) ); - ] - -let get_assumed_info (id : A.assumed_fun_id) : assumed_info = - match List.find_opt (fun (id', _, _, _) -> id = id') assumed_infos with - | Some info -> info - | None -> - raise - (Failure ("get_assumed_info: not found: " ^ A.show_assumed_fun_id id)) - -let get_assumed_sig (id : A.assumed_fun_id) : A.fun_sig = - let _, sg, _, _ = get_assumed_info id in - sg - -let get_assumed_name (id : A.assumed_fun_id) : fun_name = - let _, _, _, name = get_assumed_info id in - name - -let assumed_can_fail (id : A.assumed_fun_id) : bool = - let _, _, b, _ = get_assumed_info id in - b diff --git a/src/Collections.ml b/src/Collections.ml deleted file mode 100644 index 0933b3e4..00000000 --- a/src/Collections.ml +++ /dev/null @@ -1,378 +0,0 @@ -(** The following file redefines several modules like Map or Set. *) - -module F = Format - -module List = struct - include List - - (** Split a list at a given index. - - [split_at ls i] splits [ls] into two lists where the first list has - length [i]. - - Raise [Failure] if the list is too short. - *) - let rec split_at (ls : 'a list) (i : int) = - if i < 0 then raise (Invalid_argument "split_at take positive integers") - else if i = 0 then ([], ls) - else - match ls with - | [] -> - raise - (Failure "The int given to split_at should be <= the list's length") - | x :: ls' -> - let ls1, ls2 = split_at ls' (i - 1) in - (x :: ls1, ls2) - - (** Pop the last element of a list - - Raise [Failure] if the list is empty. - *) - let rec pop_last (ls : 'a list) : 'a list * 'a = - match ls with - | [] -> raise (Failure "The list is empty") - | [ x ] -> ([], x) - | x :: ls -> - let ls, last = pop_last ls in - (x :: ls, last) - - (** Return the n first elements of the list *) - let prefix (n : int) (ls : 'a list) : 'a list = fst (split_at ls n) - - (** Iter and link the iterations. - - Iterate over a list, but call a function between every two elements - (but not before the first element, and not after the last). - *) - let iter_link (link : unit -> unit) (f : 'a -> unit) (ls : 'a list) : unit = - let rec iter ls = - match ls with - | [] -> () - | [ x ] -> f x - | x :: y :: ls -> - f x; - link (); - iter (y :: ls) - in - iter ls - - (** Fold and link the iterations. - - Similar to {!iter_link} but for fold left operations. - *) - let fold_left_link (link : unit -> unit) (f : 'a -> 'b -> 'a) (init : 'a) - (ls : 'b list) : 'a = - let rec fold (acc : 'a) (ls : 'b list) : 'a = - match ls with - | [] -> acc - | [ x ] -> f acc x - | x :: y :: ls -> - let acc = f acc x in - link (); - fold acc (y :: ls) - in - fold init ls - - let to_cons_nil (ls : 'a list) : 'a = - match ls with - | [ x ] -> x - | _ -> raise (Failure "The list should have length exactly one") - - let pop (ls : 'a list) : 'a * 'a list = - match ls with - | x :: ls' -> (x, ls') - | _ -> raise (Failure "The list should have length > 0") -end - -module type OrderedType = sig - include Map.OrderedType - - val to_string : t -> string - val pp_t : Format.formatter -> t -> unit - val show_t : t -> string -end - -(** Ordered string *) -module OrderedString : OrderedType with type t = string = struct - include String - - let to_string s = s - let pp_t fmt s = Format.pp_print_string fmt s - let show_t s = s -end - -module type Map = sig - include Map.S - - val add_list : (key * 'a) list -> 'a t -> 'a t - val of_list : (key * 'a) list -> 'a t - - (** "Simple" pretty printing function. - - Is useful when we need to customize a bit [show_t], but without using - something as burdensome as [pp_t]. - - [to_string (Some indent) m] prints [m] by breaking line after every binding - and inserting [indent]. - *) - val to_string : string option -> ('a -> string) -> 'a t -> string - - val pp : (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a t -> unit - val show : ('a -> string) -> 'a t -> string -end - -module MakeMap (Ord : OrderedType) : Map with type key = Ord.t = struct - module Map = Map.Make (Ord) - include Map - - let add_list bl m = List.fold_left (fun s (key, e) -> add key e s) m bl - let of_list bl = add_list bl empty - - let to_string indent_opt a_to_string m = - let indent, break = - match indent_opt with Some indent -> (indent, "\n") | None -> ("", " ") - in - let sep = "," ^ break in - let ls = - Map.fold - (fun key v ls -> - (indent ^ Ord.to_string key ^ " -> " ^ a_to_string v) :: ls) - m [] - in - match ls with - | [] -> "{}" - | _ -> "{" ^ break ^ String.concat sep (List.rev ls) ^ break ^ "}" - - let pp (pp_a : Format.formatter -> 'a -> unit) (fmt : Format.formatter) - (m : 'a t) : unit = - let pp_string = F.pp_print_string fmt in - let pp_space () = F.pp_print_space fmt () in - pp_string "{"; - F.pp_open_box fmt 2; - Map.iter - (fun key x -> - Ord.pp_t fmt key; - pp_space (); - pp_string "->"; - pp_space (); - pp_a fmt x; - pp_string ","; - F.pp_print_break fmt 1 0) - m; - F.pp_close_box fmt (); - F.pp_print_break fmt 0 0; - pp_string "}" - - let show show_a m = to_string None show_a m -end - -module type Set = sig - include Set.S - - val add_list : elt list -> t -> t - val of_list : elt list -> t - - (** "Simple" pretty printing function. - - Is useful when we need to customize a bit [show_t], but without using - something as burdensome as [pp_t]. - - [to_string (Some indent) s] prints [s] by breaking line after every element - and inserting [indent]. - *) - val to_string : string option -> t -> string - - val pp : Format.formatter -> t -> unit - val show : t -> string - val pairwise_distinct : elt list -> bool -end - -module MakeSet (Ord : OrderedType) : Set with type elt = Ord.t = struct - module Set = Set.Make (Ord) - include Set - - let add_list bl s = List.fold_left (fun s e -> add e s) s bl - let of_list bl = add_list bl empty - - let to_string indent_opt m = - let indent, break = - match indent_opt with Some indent -> (indent, "\n") | None -> ("", " ") - in - let sep = "," ^ break in - let ls = Set.fold (fun v ls -> (indent ^ Ord.to_string v) :: ls) m [] in - match ls with - | [] -> "{}" - | _ -> "{" ^ break ^ String.concat sep (List.rev ls) ^ break ^ "}" - - let pp (fmt : Format.formatter) (m : t) : unit = - let pp_string = F.pp_print_string fmt in - pp_string "{"; - F.pp_open_box fmt 2; - Set.iter - (fun x -> - Ord.pp_t fmt x; - pp_string ","; - F.pp_print_break fmt 1 0) - m; - F.pp_close_box fmt (); - F.pp_print_break fmt 0 0; - pp_string "}" - - let show s = to_string None s - - let pairwise_distinct ls = - let s = ref empty in - let rec check ls = - match ls with - | [] -> true - | x :: ls' -> - if mem x !s then false - else ( - s := add x !s; - check ls') - in - check ls -end - -(** A map where the bindings are injective (i.e., if two keys are distinct, - their bindings are distinct). - - This is useful for instance when generating mappings from our internal - identifiers to names (i.e., strings) when generating code, in order to - make sure that we don't have potentially dangerous collisions. - *) -module type InjMap = sig - type key - type elem - type t - - val empty : t - val is_empty : t -> bool - val mem : key -> t -> bool - val add : key -> elem -> t -> t - val singleton : key -> elem -> t - val remove : key -> t -> t - val compare : (elem -> elem -> int) -> t -> t -> int - val equal : (elem -> elem -> bool) -> t -> t -> bool - val iter : (key -> elem -> unit) -> t -> unit - val fold : (key -> elem -> 'b -> 'b) -> t -> 'b -> 'b - val for_all : (key -> elem -> bool) -> t -> bool - val exists : (key -> elem -> bool) -> t -> bool - val filter : (key -> elem -> bool) -> t -> t - val partition : (key -> elem -> bool) -> t -> t * t - val cardinal : t -> int - val bindings : t -> (key * elem) list - val min_binding : t -> key * elem - val min_binding_opt : t -> (key * elem) option - val max_binding : t -> key * elem - val max_binding_opt : t -> (key * elem) option - val choose : t -> key * elem - val choose_opt : t -> (key * elem) option - val split : key -> t -> t * elem option * t - val find : key -> t -> elem - val find_opt : key -> t -> elem option - val find_first : (key -> bool) -> t -> key * elem - val find_first_opt : (key -> bool) -> t -> (key * elem) option - val find_last : (key -> bool) -> t -> key * elem - val find_last_opt : (key -> bool) -> t -> (key * elem) option - val to_seq : t -> (key * elem) Seq.t - val to_seq_from : key -> t -> (key * elem) Seq.t - val add_seq : (key * elem) Seq.t -> t -> t - val of_seq : (key * elem) Seq.t -> t - val add_list : (key * elem) list -> t -> t - val of_list : (key * elem) list -> t -end - -(** See {!InjMap} *) -module MakeInjMap (Key : OrderedType) (Elem : OrderedType) : - InjMap with type key = Key.t with type elem = Elem.t = struct - module Map = MakeMap (Key) - module Set = MakeSet (Elem) - - type key = Key.t - type elem = Elem.t - type t = { map : elem Map.t; elems : Set.t } - - let empty = { map = Map.empty; elems = Set.empty } - let is_empty m = Map.is_empty m.map - let mem k m = Map.mem k m.map - - let add k e m = - assert (not (Set.mem e m.elems)); - { map = Map.add k e m.map; elems = Set.add e m.elems } - - let singleton k e = { map = Map.singleton k e; elems = Set.singleton e } - - let remove k m = - match Map.find_opt k m.map with - | None -> m - | Some x -> { map = Map.remove k m.map; elems = Set.remove x m.elems } - - let compare f m1 m2 = Map.compare f m1.map m2.map - let equal f m1 m2 = Map.equal f m1.map m2.map - let iter f m = Map.iter f m.map - let fold f m x = Map.fold f m.map x - let for_all f m = Map.for_all f m.map - let exists f m = Map.exists f m.map - - (** Small helper *) - let bindings_to_elems_set (bls : (key * elem) list) : Set.t = - let elems = List.map snd bls in - let elems = List.fold_left (fun s e -> Set.add e s) Set.empty elems in - elems - - (** Small helper *) - let map_to_elems_set (map : elem Map.t) : Set.t = - bindings_to_elems_set (Map.bindings map) - - (** Small helper *) - let map_to_t (map : elem Map.t) : t = - let elems = map_to_elems_set map in - { map; elems } - - let filter f m = - let map = Map.filter f m.map in - let elems = map_to_elems_set map in - { map; elems } - - let partition f m = - let map1, map2 = Map.partition f m.map in - (map_to_t map1, map_to_t map2) - - let cardinal m = Map.cardinal m.map - let bindings m = Map.bindings m.map - let min_binding m = Map.min_binding m.map - let min_binding_opt m = Map.min_binding_opt m.map - let max_binding m = Map.max_binding m.map - let max_binding_opt m = Map.max_binding_opt m.map - let choose m = Map.choose m.map - let choose_opt m = Map.choose_opt m.map - - let split k m = - let l, data, r = Map.split k m.map in - let l = map_to_t l in - let r = map_to_t r in - (l, data, r) - - let find k m = Map.find k m.map - let find_opt k m = Map.find_opt k m.map - let find_first k m = Map.find_first k m.map - let find_first_opt k m = Map.find_first_opt k m.map - let find_last k m = Map.find_last k m.map - let find_last_opt k m = Map.find_last_opt k m.map - let to_seq m = Map.to_seq m.map - let to_seq_from k m = Map.to_seq_from k m.map - - let rec add_seq s m = - (* Note that it is important to check that we don't add bindings mapping - * to the same element *) - match s () with - | Seq.Nil -> m - | Seq.Cons ((k, e), s) -> - let m = add k e m in - add_seq s m - - let of_seq s = add_seq s empty - let add_list ls m = List.fold_left (fun m (key, elem) -> add key elem m) m ls - let of_list ls = add_list ls empty -end diff --git a/src/ConstStrings.ml b/src/ConstStrings.ml deleted file mode 100644 index ae169a2e..00000000 --- a/src/ConstStrings.ml +++ /dev/null @@ -1,7 +0,0 @@ -(** Some utilities *) - -(** Basename for state variables (introduced when using state-error monads) *) -let state_basename = "st" - -(** ADT constructor prefix (used when pretty-printing) *) -let constructor_prefix = "Mk" diff --git a/src/Contexts.ml b/src/Contexts.ml deleted file mode 100644 index 510976f4..00000000 --- a/src/Contexts.ml +++ /dev/null @@ -1,472 +0,0 @@ -open Types -open Values -open LlbcAst -module V = Values -open ValuesUtils - -(** Some global counters. - - Note that those counters were initially stored in {!eval_ctx} values, - but it proved better to make them global and stateful: - - when branching (and thus executing on several paths with different - contexts) it is better to really have unique ids everywhere (and - not have fresh ids shared by several contexts even though introduced - after the branching) because at some point we might need to merge the - different contexts - - also, it is a lot more convenient to not store those counters in contexts - objects - - ============= - **WARNING**: - ============= - Pay attention when playing with closures, as you may not always generate - fresh identifiers without noticing it, especially when using type abbreviations. - For instance, consider the following: - {[ - type fun_type = unit -> ... - fn f x : fun_type = - let id = fresh_id () in - ... - - let g = f x in // <-- the fresh identifier gets generated here - let x1 = g () in // <-- no fresh generation here - let x2 = g () in - ... - ]} - - This is why, in such cases, we often introduce all the inputs, even - when they are not used (which happens!). - {[ - fn f x : fun_type = - fun .. -> - let id = fresh_id () in - ... - ]} - - Note that in practice, we never reuse closures, except when evaluating - a branching in the execution (which is fine, because the branches evaluate - independentely of each other). Still, it is always a good idea to be - defensive. - - However, the same problem arises with logging. - - Also, a more defensive way would be to not use global references, and - store the counters in the evaluation context. This is actually what was - originally done, before we updated the code to use global counters because - it proved more convenient (and even before updating the code of the - interpreter to use CPS). - *) - -let symbolic_value_id_counter, fresh_symbolic_value_id = - SymbolicValueId.fresh_stateful_generator () - -let borrow_id_counter, fresh_borrow_id = BorrowId.fresh_stateful_generator () -let region_id_counter, fresh_region_id = RegionId.fresh_stateful_generator () - -let abstraction_id_counter, fresh_abstraction_id = - AbstractionId.fresh_stateful_generator () - -let fun_call_id_counter, fresh_fun_call_id = - FunCallId.fresh_stateful_generator () - -(** We shouldn't need to reset the global counters, but it might be good to - do it from time to time, for instance every time we start evaluating/ - synthesizing a function. - - The reasons are manifold: - - it might prevent the counters from overflowing (although this seems - extremely unlikely - as a side node: we have overflow checks to make - sure the synthesis doesn't get impacted by potential overflows) - - most importantly, it allows to always manipulate low values, which - is always a lot more readable when debugging - *) -let reset_global_counters () = - symbolic_value_id_counter := SymbolicValueId.generator_zero; - borrow_id_counter := BorrowId.generator_zero; - region_id_counter := RegionId.generator_zero; - abstraction_id_counter := AbstractionId.generator_zero; - fun_call_id_counter := FunCallId.generator_zero - -(** A binder used in an environment, to map a variable to a value *) -type binder = { - index : VarId.id; (** Unique variable identifier *) - name : string option; (** Possible name *) -} -[@@deriving show] - -(** Environment value: mapping from variable to value, abstraction (only - used in symbolic mode) or stack frame delimiter. - - TODO: rename Var (-> Binding?) - *) -type env_elem = - | Var of (binder option[@opaque]) * typed_value - (** Variable binding - the binder is None if the variable is a dummy variable - (we use dummy variables to store temporaries while doing bookkeeping such - as ending borrows for instance). *) - | Abs of abs - | Frame -[@@deriving - show, - visitors - { - name = "iter_env_elem"; - variety = "iter"; - ancestors = [ "iter_abs" ]; - nude = true (* Don't inherit {!VisitorsRuntime.iter} *); - concrete = true; - }, - visitors - { - name = "map_env_elem"; - variety = "map"; - ancestors = [ "map_abs" ]; - nude = true (* Don't inherit {!VisitorsRuntime.iter} *); - concrete = true; - }] - -type env = env_elem list -[@@deriving - show, - visitors - { - name = "iter_env"; - variety = "iter"; - ancestors = [ "iter_env_elem" ]; - nude = true (* Don't inherit {!VisitorsRuntime.iter} *); - concrete = true; - }, - visitors - { - name = "map_env"; - variety = "map"; - ancestors = [ "map_env_elem" ]; - nude = true (* Don't inherit {!VisitorsRuntime.iter} *); - concrete = true; - }] - -type interpreter_mode = ConcreteMode | SymbolicMode [@@deriving show] - -type config = { - mode : interpreter_mode; - (** Concrete mode (interpreter) or symbolic mode (for synthesis) **) - check_invariants : bool; - (** Check that invariants are maintained whenever we execute a statement *) - greedy_expand_symbolics_with_borrows : bool; - (** Expand all symbolic values containing borrows upon introduction - allows - to use restrict ourselves to a simpler model for the projectors over - symbolic values. - The interpreter fails if doing this requires to do a branching (because - we need to expand an enumeration with strictly more than one variant) - or if we need to expand a recursive type (because this leads to looping). - *) - allow_bottom_below_borrow : bool; - (** Experimental. - - We sometimes want to temporarily break the invariant that there is no - bottom value below a borrow. If this value is true, we don't check - the invariant, and the rule becomes: we can't end a borrow *if* it contains - a bottom value. The consequence is that it becomes ok to temporarily - have bottom below a borrow, if we put something else inside before ending - the borrow. - - For instance, when evaluating an assignment, we move the value which - will be overwritten then do some administrative tasks with the borrows, - then move the rvalue to its destination. We currently want to be able - to check the invariants every time we end a borrow/an abstraction, - meaning at intermediate steps of the assignment where the invariants - might actually be broken. - *) - return_unit_end_abs_with_no_loans : bool; - (** If a function doesn't return any borrows, we can immediately call - its backward functions. If this option is on, whenever we call a - function *and* this function returns unit, we immediately end all the - abstractions which are introduced and don't contain loans. This can be - useful to make the code cleaner (the backward function is introduced - where the function call happened) and make sure all forward functions - with no return value are followed by a backward function. - *) -} -[@@deriving show] - -(** See {!config} *) -type partial_config = { - check_invariants : bool; - greedy_expand_symbolics_with_borrows : bool; - allow_bottom_below_borrow : bool; - return_unit_end_abs_with_no_loans : bool; -} - -let config_of_partial (mode : interpreter_mode) (config : partial_config) : - config = - { - mode; - check_invariants = config.check_invariants; - greedy_expand_symbolics_with_borrows = - config.greedy_expand_symbolics_with_borrows; - allow_bottom_below_borrow = config.allow_bottom_below_borrow; - return_unit_end_abs_with_no_loans = config.return_unit_end_abs_with_no_loans; - } - -type type_context = { - type_decls_groups : Crates.type_declaration_group TypeDeclId.Map.t; - type_decls : type_decl TypeDeclId.Map.t; - type_infos : TypesAnalysis.type_infos; -} -[@@deriving show] - -type fun_context = { fun_decls : fun_decl FunDeclId.Map.t } [@@deriving show] - -type global_context = { global_decls : global_decl GlobalDeclId.Map.t } -[@@deriving show] - -(** Evaluation context *) -type eval_ctx = { - type_context : type_context; - fun_context : fun_context; - global_context : global_context; - type_vars : type_var list; - env : env; - ended_regions : RegionId.Set.t; -} -[@@deriving show] - -let lookup_type_var (ctx : eval_ctx) (vid : TypeVarId.id) : type_var = - TypeVarId.nth ctx.type_vars vid - -let opt_binder_has_vid (bv : binder option) (vid : VarId.id) : bool = - match bv with Some bv -> bv.index = vid | None -> false - -let ctx_lookup_binder (ctx : eval_ctx) (vid : VarId.id) : binder = - (* TOOD: we might want to stop at the end of the frame *) - let rec lookup env = - match env with - | [] -> - raise (Invalid_argument ("Variable not found: " ^ VarId.to_string vid)) - | Var (var, _) :: env' -> - if opt_binder_has_vid var vid then Option.get var else lookup env' - | (Abs _ | Frame) :: env' -> lookup env' - in - lookup ctx.env - -(** TODO: make this more efficient with maps *) -let ctx_lookup_type_decl (ctx : eval_ctx) (tid : TypeDeclId.id) : type_decl = - TypeDeclId.Map.find tid ctx.type_context.type_decls - -(** TODO: make this more efficient with maps *) -let ctx_lookup_fun_decl (ctx : eval_ctx) (fid : FunDeclId.id) : fun_decl = - FunDeclId.Map.find fid ctx.fun_context.fun_decls - -(** TODO: make this more efficient with maps *) -let ctx_lookup_global_decl (ctx : eval_ctx) (gid : GlobalDeclId.id) : - global_decl = - GlobalDeclId.Map.find gid ctx.global_context.global_decls - -(** Retrieve a variable's value in an environment *) -let env_lookup_var_value (env : env) (vid : VarId.id) : typed_value = - (* We take care to stop at the end of current frame: different variables - in different frames can have the same id! - *) - let rec lookup env = - match env with - | [] -> failwith "Unexpected" - | Var (var, v) :: env' -> - if opt_binder_has_vid var vid then v else lookup env' - | Abs _ :: env' -> lookup env' - | Frame :: _ -> failwith "End of frame" - in - lookup env - -(** Retrieve a variable's value in an evaluation context *) -let ctx_lookup_var_value (ctx : eval_ctx) (vid : VarId.id) : typed_value = - env_lookup_var_value ctx.env vid - -(** Update a variable's value in an environment - - This is a helper function: it can break invariants and doesn't perform - any check. -*) -let env_update_var_value (env : env) (vid : VarId.id) (nv : typed_value) : env = - (* We take care to stop at the end of current frame: different variables - in different frames can have the same id! - *) - let rec update env = - match env with - | [] -> failwith "Unexpected" - | Var (var, v) :: env' -> - if opt_binder_has_vid var vid then Var (var, nv) :: env' - else Var (var, v) :: update env' - | Abs abs :: env' -> Abs abs :: update env' - | Frame :: _ -> failwith "End of frame" - in - update env - -let var_to_binder (var : var) : binder = { index = var.index; name = var.name } - -(** Update a variable's value in an evaluation context. - - This is a helper function: it can break invariants and doesn't perform - any check. -*) -let ctx_update_var_value (ctx : eval_ctx) (vid : VarId.id) (nv : typed_value) : - eval_ctx = - { ctx with env = env_update_var_value ctx.env vid nv } - -(** Push a variable in the context's environment. - - Checks that the pushed variable and its value have the same type (this - is important). -*) -let ctx_push_var (ctx : eval_ctx) (var : var) (v : typed_value) : eval_ctx = - assert (var.var_ty = v.ty); - let bv = var_to_binder var in - { ctx with env = Var (Some bv, v) :: ctx.env } - -(** Push a list of variables. - - Checks that the pushed variables and their values have the same type (this - is important). -*) -let ctx_push_vars (ctx : eval_ctx) (vars : (var * typed_value) list) : eval_ctx - = - assert ( - List.for_all - (fun (var, (value : typed_value)) -> var.var_ty = value.ty) - vars); - let vars = - List.map (fun (var, value) -> Var (Some (var_to_binder var), value)) vars - in - let vars = List.rev vars in - { ctx with env = List.append vars ctx.env } - -(** Push a dummy variable in the context's environment. *) -let ctx_push_dummy_var (ctx : eval_ctx) (v : typed_value) : eval_ctx = - { ctx with env = Var (None, v) :: ctx.env } - -(** Pop the first dummy variable from a context's environment. *) -let ctx_pop_dummy_var (ctx : eval_ctx) : eval_ctx * typed_value = - let rec pop_var (env : env) : env * typed_value = - match env with - | [] -> failwith "Could not find a dummy variable" - | Var (None, v) :: env -> (env, v) - | ee :: env -> - let env, v = pop_var env in - (ee :: env, v) - in - let env, v = pop_var ctx.env in - ({ ctx with env }, v) - -(** Read the first dummy variable in a context's environment. *) -let ctx_read_first_dummy_var (ctx : eval_ctx) : typed_value = - let rec read_var (env : env) : typed_value = - match env with - | [] -> failwith "Could not find a dummy variable" - | Var (None, v) :: _env -> v - | _ :: env -> read_var env - in - read_var ctx.env - -(** Push an uninitialized variable (which thus maps to {!Values.Bottom}) *) -let ctx_push_uninitialized_var (ctx : eval_ctx) (var : var) : eval_ctx = - ctx_push_var ctx var (mk_bottom var.var_ty) - -(** Push a list of uninitialized variables (which thus map to {!Values.Bottom}) *) -let ctx_push_uninitialized_vars (ctx : eval_ctx) (vars : var list) : eval_ctx = - let vars = List.map (fun v -> (v, mk_bottom v.var_ty)) vars in - ctx_push_vars ctx vars - -let env_lookup_abs (env : env) (abs_id : V.AbstractionId.id) : V.abs = - let rec lookup env = - match env with - | [] -> failwith "Unexpected" - | Var (_, _) :: env' -> lookup env' - | Abs abs :: env' -> if abs.abs_id = abs_id then abs else lookup env' - | Frame :: env' -> lookup env' - in - lookup env - -let ctx_lookup_abs (ctx : eval_ctx) (abs_id : V.AbstractionId.id) : V.abs = - env_lookup_abs ctx.env abs_id - -let ctx_type_decl_is_rec (ctx : eval_ctx) (id : TypeDeclId.id) : bool = - let decl_group = TypeDeclId.Map.find id ctx.type_context.type_decls_groups in - match decl_group with Crates.Rec _ -> true | Crates.NonRec _ -> false - -(** Visitor to iterate over the values in the *current* frame *) -class ['self] iter_frame = - object (self : 'self) - inherit [_] V.iter_abs - - method visit_Var : 'acc -> binder option -> typed_value -> unit = - fun acc _vid v -> self#visit_typed_value acc v - - method visit_Abs : 'acc -> abs -> unit = - fun acc abs -> self#visit_abs acc abs - - method visit_env_elem : 'acc -> env_elem -> unit = - fun acc em -> - match em with - | Var (vid, v) -> self#visit_Var acc vid v - | Abs abs -> self#visit_Abs acc abs - | Frame -> failwith "Unreachable" - - method visit_env : 'acc -> env -> unit = - fun acc env -> - match env with - | [] -> () - | Frame :: _ -> (* We stop here *) () - | em :: env -> - self#visit_env_elem acc em; - self#visit_env acc env - end - -(** Visitor to map over the values in the *current* frame *) -class ['self] map_frame_concrete = - object (self : 'self) - inherit [_] V.map_abs - - method visit_Var : 'acc -> binder option -> typed_value -> env_elem = - fun acc vid v -> - let v = self#visit_typed_value acc v in - Var (vid, v) - - method visit_Abs : 'acc -> abs -> env_elem = - fun acc abs -> Abs (self#visit_abs acc abs) - - method visit_env_elem : 'acc -> env_elem -> env_elem = - fun acc em -> - match em with - | Var (vid, v) -> self#visit_Var acc vid v - | Abs abs -> self#visit_Abs acc abs - | Frame -> failwith "Unreachable" - - method visit_env : 'acc -> env -> env = - fun acc env -> - match env with - | [] -> [] - | Frame :: env -> (* We stop here *) Frame :: env - | em :: env -> - let em = self#visit_env_elem acc em in - let env = self#visit_env acc env in - em :: env - end - -(** Visitor to iterate over the values in a context *) -class ['self] iter_eval_ctx = - object (_self : 'self) - inherit [_] iter_env as super - - method visit_eval_ctx : 'acc -> eval_ctx -> unit = - fun acc ctx -> super#visit_env acc ctx.env - end - -(** Visitor to map the values in a context *) -class ['self] map_eval_ctx = - object (_self : 'self) - inherit [_] map_env as super - - method visit_eval_ctx : 'acc -> eval_ctx -> eval_ctx = - fun acc ctx -> - let env = super#visit_env acc ctx.env in - { ctx with env } - end diff --git a/src/Cps.ml b/src/Cps.ml deleted file mode 100644 index c2c0363b..00000000 --- a/src/Cps.ml +++ /dev/null @@ -1,193 +0,0 @@ -(** This module defines various utilities to write the interpretation functions - in continuation passing style. *) - -module T = Types -module V = Values -module C = Contexts -module SA = SymbolicAst - -(** TODO: change the name *) -type eval_error = EPanic - -(** Result of evaluating a statement *) -type statement_eval_res = - | Unit - | Break of int - | Continue of int - | Return - | Panic - -(** Synthesized expresssion - dummy for now *) -type sexpr = SOne | SList of sexpr list - -type eval_result = SA.expression option - -(** Continuation function *) -type m_fun = C.eval_ctx -> eval_result - -(** Continuation taking another continuation as parameter *) -type cm_fun = m_fun -> m_fun - -(** Continuation taking a typed value as parameter - TODO: use more *) -type typed_value_m_fun = V.typed_value -> m_fun - -(** Continuation taking another continuation as parameter and a typed - value as parameter. - *) -type typed_value_cm_fun = V.typed_value -> cm_fun - -(** Type of a continuation used when evaluating a statement *) -type st_m_fun = statement_eval_res -> m_fun - -(** Type of a continuation used when evaluating a statement *) -type st_cm_fun = st_m_fun -> m_fun - -(** Convert a unit function to a cm function *) -let unit_to_cm_fun (f : C.eval_ctx -> unit) : cm_fun = - fun cf ctx -> - f ctx; - cf ctx - -(** *) -let update_to_cm_fun (f : C.eval_ctx -> C.eval_ctx) : cm_fun = - fun cf ctx -> - let ctx = f ctx in - cf ctx - -(** Composition of functions taking continuations as parameters. - We tried to make this as general as possible. *) -let comp (f : 'c -> 'd -> 'e) (g : ('a -> 'b) -> 'c) : ('a -> 'b) -> 'd -> 'e = - fun cf ctx -> f (g cf) ctx - -let comp_unit (f : cm_fun) (g : C.eval_ctx -> unit) : cm_fun = - comp f (unit_to_cm_fun g) - -let comp_update (f : cm_fun) (g : C.eval_ctx -> C.eval_ctx) : cm_fun = - comp f (update_to_cm_fun g) - -(** This is just a test, to check that {!comp} is general enough to handle a case - where a function must compute a value and give it to the continuation. - It happens for functions like {!InterpreterExpressions.eval_operand}. - - Keeping this here also makes it a good reference, when one wants to figure - out the signatures he should use for such a composition. - *) -let comp_ret_val (f : (V.typed_value -> m_fun) -> m_fun) - (g : m_fun -> V.typed_value -> m_fun) : cm_fun = - comp f g - -let apply (f : cm_fun) (g : m_fun) : m_fun = fun ctx -> f g ctx -let id_cm_fun : cm_fun = fun cf ctx -> cf ctx - -(** If we have a list of [inputs] of type ['a list] and a function [f] which - evaluates one element of type ['a] to compute a result of type ['b] before - giving it to a continuation, the following function performs a fold operation: - it evaluates all the inputs one by one by accumulating the results in a list, - and gives the list to a continuation. - - Note that we make sure that the results are listed in the order in - which they were computed (the first element of the list is the result - of applying [f] to the first element of the inputs). - - See the unit test below for an illustration. - *) -let fold_left_apply_continuation (f : 'a -> ('c -> 'd) -> 'c -> 'd) - (inputs : 'a list) (cf : 'c -> 'd) : 'c -> 'd = - let rec eval_list (inputs : 'a list) (cf : 'c -> 'd) : 'c -> 'd = - fun ctx -> - match inputs with - | [] -> cf ctx - | x :: inputs -> comp (f x) (fun cf -> eval_list inputs cf) cf ctx - in - eval_list inputs cf - -(** Unit test/example for {!fold_left_apply_continuation} *) -let _ = - fold_left_apply_continuation - (fun x cf (ctx : int) -> cf (ctx + x)) - [ 1; 20; 300; 4000 ] - (fun (ctx : int) -> assert (ctx = 4321)) - 0 - -(** If we have a list of [inputs] of type ['a list] and a function [f] which - evaluates one element of type ['a] to compute a result of type ['b] before - giving it to a continuation, the following function performs a fold operation: - it evaluates all the inputs one by one by accumulating the results in a list, - and gives the list to a continuation. - - Note that we make sure that the results are listed in the order in - which they were computed (the first element of the list is the result - of applying [f] to the first element of the inputs). - - See the unit test below for an illustration. - *) -let fold_left_list_apply_continuation (f : 'a -> ('b -> 'c -> 'd) -> 'c -> 'd) - (inputs : 'a list) (cf : 'b list -> 'c -> 'd) : 'c -> 'd = - let rec eval_list (inputs : 'a list) (cf : 'b list -> 'c -> 'd) - (outputs : 'b list) : 'c -> 'd = - fun ctx -> - match inputs with - | [] -> cf (List.rev outputs) ctx - | x :: inputs -> - comp (f x) (fun cf v -> eval_list inputs cf (v :: outputs)) cf ctx - in - eval_list inputs cf [] - -(** Unit test/example for {!fold_left_list_apply_continuation} *) -let _ = - fold_left_list_apply_continuation - (fun x cf (ctx : unit) -> cf (10 + x) ctx) - [ 0; 1; 2; 3; 4 ] - (fun values _ctx -> assert (values = [ 10; 11; 12; 13; 14 ])) - () - -(** Composition of functions taking continuations as parameters. - - We sometimes have the following situation, where we want to compose three - functions [send], [transmit] and [receive] such that: - - those three functions take continuations as parameters - - [send] generates a value and gives it to its continuation - - [receive] expects a value (so we can compose [send] and [receive] like - so: [comp send receive]) - - [transmit] doesn't expect any value and needs to be called between [send] - and [receive] - - In this situation, we need to take the value given by [send] and "transmit" - it to [receive]. - - This is what this function does (see the unit test below for an illustration). - *) -let comp_transmit (f : ('v -> 'm) -> 'n) (g : 'm -> 'm) : ('v -> 'm) -> 'n = - fun cf -> f (fun v -> g (cf v)) - -(** Example of use of {!comp_transmit} *) -let () = - let return3 (cf : int -> unit -> unit) (ctx : unit) = cf 3 ctx in - let do_nothing (cf : unit -> unit) (ctx : unit) = cf ctx in - let consume3 (x : int) (ctx : unit) : unit = - assert (x = 3); - ctx - in - let cc = comp_transmit return3 do_nothing in - let cc = cc consume3 in - cc () - -(** Sometimes, we want to compose a function with a continuation which checks - its computed value and its updated context, before transmitting them - *) -let comp_check_value (f : ('v -> 'ctx -> 'a) -> 'ctx -> 'b) - (g : 'v -> 'ctx -> unit) : ('v -> 'ctx -> 'a) -> 'ctx -> 'b = - fun cf -> - f (fun v ctx -> - g v ctx; - cf v ctx) - -(** This case is similar to {!comp_check_value}, but even simpler (we only check - the context) - *) -let comp_check_ctx (f : ('ctx -> 'a) -> 'ctx -> 'b) (g : 'ctx -> unit) : - ('ctx -> 'a) -> 'ctx -> 'b = - fun cf -> - f (fun ctx -> - g ctx; - cf ctx) diff --git a/src/Crates.ml b/src/Crates.ml deleted file mode 100644 index 844afb94..00000000 --- a/src/Crates.ml +++ /dev/null @@ -1,90 +0,0 @@ -open Types -open LlbcAst - -type 'id g_declaration_group = NonRec of 'id | Rec of 'id list -[@@deriving show] - -type type_declaration_group = TypeDeclId.id g_declaration_group -[@@deriving show] - -type fun_declaration_group = FunDeclId.id g_declaration_group [@@deriving show] - -(** Module declaration. Globals cannot be mutually recursive. *) -type declaration_group = - | Type of type_declaration_group - | Fun of fun_declaration_group - | Global of GlobalDeclId.id -[@@deriving show] - -type llbc_crate = { - name : string; - declarations : declaration_group list; - types : type_decl list; - functions : fun_decl list; - globals : global_decl list; -} -(** LLBC crate *) - -let compute_defs_maps (c : llbc_crate) : - type_decl TypeDeclId.Map.t - * fun_decl FunDeclId.Map.t - * global_decl GlobalDeclId.Map.t = - let types_map = - List.fold_left - (fun m (def : type_decl) -> TypeDeclId.Map.add def.def_id def m) - TypeDeclId.Map.empty c.types - in - let funs_map = - List.fold_left - (fun m (def : fun_decl) -> FunDeclId.Map.add def.def_id def m) - FunDeclId.Map.empty c.functions - in - let globals_map = - List.fold_left - (fun m (def : global_decl) -> GlobalDeclId.Map.add def.def_id def m) - GlobalDeclId.Map.empty c.globals - in - (types_map, funs_map, globals_map) - -(** Split a module's declarations between types, functions and globals *) -let split_declarations (decls : declaration_group list) : - type_declaration_group list - * fun_declaration_group list - * GlobalDeclId.id list = - let rec split decls = - match decls with - | [] -> ([], [], []) - | d :: decls' -> ( - let types, funs, globals = split decls' in - match d with - | Type decl -> (decl :: types, funs, globals) - | Fun decl -> (types, decl :: funs, globals) - | Global decl -> (types, funs, decl :: globals)) - in - split decls - -(** Split a module's declarations into three maps from type/fun/global ids to - declaration groups. - *) -let split_declarations_to_group_maps (decls : declaration_group list) : - type_declaration_group TypeDeclId.Map.t - * fun_declaration_group FunDeclId.Map.t - * GlobalDeclId.Set.t = - let module G (M : Map.S) = struct - let add_group (map : M.key g_declaration_group M.t) - (group : M.key g_declaration_group) : M.key g_declaration_group M.t = - match group with - | NonRec id -> M.add id group map - | Rec ids -> List.fold_left (fun map id -> M.add id group map) map ids - - let create_map (groups : M.key g_declaration_group list) : - M.key g_declaration_group M.t = - List.fold_left add_group M.empty groups - end in - let types, funs, globals = split_declarations decls in - let module TG = G (TypeDeclId.Map) in - let types = TG.create_map types in - let module FG = G (FunDeclId.Map) in - let funs = FG.create_map funs in - let globals = GlobalDeclId.Set.of_list globals in - (types, funs, globals) diff --git a/src/Errors.ml b/src/Errors.ml deleted file mode 100644 index 31a53cf4..00000000 --- a/src/Errors.ml +++ /dev/null @@ -1,2 +0,0 @@ -exception IntegerOverflow of unit -exception Unimplemented diff --git a/src/Expressions.ml b/src/Expressions.ml deleted file mode 100644 index e2eaf1e7..00000000 --- a/src/Expressions.ml +++ /dev/null @@ -1,118 +0,0 @@ -open Types -open Values - -type field_proj_kind = - | ProjAdt of TypeDeclId.id * VariantId.id option - | ProjOption of VariantId.id - (** Option is an assumed type, coming from the standard library *) - | ProjTuple of int -[@@deriving show] -(* arity of the tuple *) - -type projection_elem = - | Deref - | DerefBox - | Field of field_proj_kind * FieldId.id -[@@deriving show] - -type projection = projection_elem list [@@deriving show] -type place = { var_id : VarId.id; projection : projection } [@@deriving show] -type borrow_kind = Shared | Mut | TwoPhaseMut [@@deriving show] - -type unop = - | Not - | Neg - | Cast of integer_type * integer_type - (** Cast an integer from a source type to a target type *) -[@@deriving show, ord] - -(** A binary operation - - Note that we merge checked binops and unchecked binops: we perform a - micro-pass on the MIR AST to remove the assertions introduced by rustc, - and later extract the binops which can fail (addition, substraction, etc.) - or have preconditions (division, remainder...) to monadic functions. - *) -type binop = - | BitXor - | BitAnd - | BitOr - | Eq - | Lt - | Le - | Ne - | Ge - | Gt - | Div - | Rem - | Add - | Sub - | Mul - | Shl - | Shr -[@@deriving show, ord] - -let all_binops = - [ - BitXor; - BitAnd; - BitOr; - Eq; - Lt; - Le; - Ne; - Ge; - Gt; - Div; - Rem; - Add; - Sub; - Mul; - Shl; - Shr; - ] - -type operand = - | Copy of place - | Move of place - | Constant of ety * constant_value -[@@deriving show] - -(** An aggregated ADT. - - Note that ADTs are desaggregated at some point in MIR. For instance, if - we have in Rust: - {[ - let ls = Cons(hd, tl); - ]} - - In MIR we have (yes, the discriminant update happens *at the end* for some - reason): - {[ - (ls as Cons).0 = move hd; - (ls as Cons).1 = move tl; - discriminant(ls) = 0; // assuming [Cons] is the variant of index 0 - ]} - - Note that in our semantics, we handle both cases (in case of desaggregated - initialization, [ls] is initialized to [⊥], then this [⊥] is expanded to - [Cons (⊥, ⊥)] upon the first assignment, at which point we can initialize - the field 0, etc.). - *) -type aggregate_kind = - | AggregatedTuple - | AggregatedOption of VariantId.id * ety - (* TODO: AggregatedOption should be merged with AggregatedAdt *) - | AggregatedAdt of - TypeDeclId.id * VariantId.id option * erased_region list * ety list -[@@deriving show] - -(* TODO: move the aggregate kind to operands *) -type rvalue = - | Use of operand - | Ref of place * borrow_kind - | UnaryOp of unop * operand - | BinaryOp of binop * operand * operand - | Discriminant of place - | Aggregate of aggregate_kind * operand list -[@@deriving show] diff --git a/src/ExpressionsUtils.ml b/src/ExpressionsUtils.ml deleted file mode 100644 index c3ccfb15..00000000 --- a/src/ExpressionsUtils.ml +++ /dev/null @@ -1,10 +0,0 @@ -module E = Expressions - -let unop_can_fail (unop : E.unop) : bool = - match unop with Neg | Cast _ -> true | Not -> false - -let binop_can_fail (binop : E.binop) : bool = - match binop with - | BitXor | BitAnd | BitOr | Eq | Lt | Le | Ne | Ge | Gt -> false - | Div | Rem | Add | Sub | Mul -> true - | Shl | Shr -> raise Errors.Unimplemented diff --git a/src/ExtractToFStar.ml b/src/ExtractToFStar.ml deleted file mode 100644 index 5d212941..00000000 --- a/src/ExtractToFStar.ml +++ /dev/null @@ -1,1638 +0,0 @@ -(** Extract to F* *) - -open Errors -open Pure -open PureUtils -open TranslateCore -open PureToExtract -open StringUtils -module F = Format - -(** A qualifier for a type definition. - - Controls whether we should use [type ...] or [and ...] (for mutually - recursive datatypes). - *) -type type_decl_qualif = - | Type (** [type t = ...] *) - | And (** [type t0 = ... and t1 = ...] *) - | AssumeType (** [assume type t] *) - | TypeVal (** In an fsti: [val t : Type0] *) - -(** A qualifier for function definitions. - - Controls whether we should use [let ...], [let rec ...] or [and ...], - or only generate a declaration with [val] or [assume val] - *) -type fun_decl_qualif = Let | LetRec | And | Val | AssumeVal - -let fun_decl_qualif_keyword (qualif : fun_decl_qualif) : string = - match qualif with - | Let -> "let" - | LetRec -> "let rec" - | And -> "and" - | Val -> "val" - | AssumeVal -> "assume val" - -(** Small helper to compute the name of an int type *) -let fstar_int_name (int_ty : integer_type) = - match int_ty with - | Isize -> "isize" - | I8 -> "i8" - | I16 -> "i16" - | I32 -> "i32" - | I64 -> "i64" - | I128 -> "i128" - | Usize -> "usize" - | U8 -> "u8" - | U16 -> "u16" - | U32 -> "u32" - | U64 -> "u64" - | U128 -> "u128" - -(** Small helper to compute the name of a unary operation *) -let fstar_unop_name (unop : unop) : string = - match unop with - | Not -> "not" - | Neg int_ty -> fstar_int_name int_ty ^ "_neg" - | Cast _ -> raise (Failure "Unsupported") - -(** Small helper to compute the name of a binary operation (note that many - binary operations like "less than" are extracted to primitive operations, - like [<]. - *) -let fstar_named_binop_name (binop : E.binop) (int_ty : integer_type) : string = - let binop = - match binop with - | Div -> "div" - | Rem -> "rem" - | Add -> "add" - | Sub -> "sub" - | Mul -> "mul" - | _ -> raise (Failure "Unreachable") - in - fstar_int_name int_ty ^ "_" ^ binop - -(** A list of keywords/identifiers used in F* and with which we want to check - collision. *) -let fstar_keywords = - let named_unops = - fstar_unop_name Not - :: List.map (fun it -> fstar_unop_name (Neg it)) T.all_signed_int_types - in - let named_binops = [ E.Div; Rem; Add; Sub; Mul ] in - let named_binops = - List.concat - (List.map - (fun bn -> - List.map (fun it -> fstar_named_binop_name bn it) T.all_int_types) - named_binops) - in - let misc = - [ - "let"; - "rec"; - "in"; - "fn"; - "val"; - "int"; - "nat"; - "list"; - "FStar"; - "FStar.Mul"; - "type"; - "match"; - "with"; - "assert"; - "assert_norm"; - "Type0"; - "unit"; - "not"; - "scalar_cast"; - ] - in - List.concat [ named_unops; named_binops; misc ] - -let fstar_assumed_adts : (assumed_ty * string) list = - [ (State, "state"); (Result, "result"); (Option, "option"); (Vec, "vec") ] - -let fstar_assumed_structs : (assumed_ty * string) list = [] - -let fstar_assumed_variants : (assumed_ty * VariantId.id * string) list = - [ - (Result, result_return_id, "Return"); - (Result, result_fail_id, "Fail"); - (Option, option_some_id, "Some"); - (Option, option_none_id, "None"); - ] - -let fstar_assumed_functions : - (A.assumed_fun_id * T.RegionGroupId.id option * string) list = - let rg0 = Some T.RegionGroupId.zero in - [ - (Replace, None, "mem_replace_fwd"); - (Replace, rg0, "mem_replace_back"); - (VecNew, None, "vec_new"); - (VecPush, None, "vec_push_fwd") (* Shouldn't be used *); - (VecPush, rg0, "vec_push_back"); - (VecInsert, None, "vec_insert_fwd") (* Shouldn't be used *); - (VecInsert, rg0, "vec_insert_back"); - (VecLen, None, "vec_len"); - (VecIndex, None, "vec_index_fwd"); - (VecIndex, rg0, "vec_index_back") (* shouldn't be used *); - (VecIndexMut, None, "vec_index_mut_fwd"); - (VecIndexMut, rg0, "vec_index_mut_back"); - ] - -let fstar_names_map_init = - { - keywords = fstar_keywords; - assumed_adts = fstar_assumed_adts; - assumed_structs = fstar_assumed_structs; - assumed_variants = fstar_assumed_variants; - assumed_functions = fstar_assumed_functions; - } - -let fstar_extract_unop (extract_expr : bool -> texpression -> unit) - (fmt : F.formatter) (inside : bool) (unop : unop) (arg : texpression) : unit - = - match unop with - | Not | Neg _ -> - let unop = fstar_unop_name unop in - if inside then F.pp_print_string fmt "("; - F.pp_print_string fmt unop; - F.pp_print_space fmt (); - extract_expr true arg; - if inside then F.pp_print_string fmt ")" - | Cast (src, tgt) -> - (* The source type is an implicit parameter *) - if inside then F.pp_print_string fmt "("; - F.pp_print_string fmt "scalar_cast"; - F.pp_print_space fmt (); - F.pp_print_string fmt - (StringUtils.capitalize_first_letter - (PrintPure.integer_type_to_string src)); - F.pp_print_space fmt (); - F.pp_print_string fmt - (StringUtils.capitalize_first_letter - (PrintPure.integer_type_to_string tgt)); - F.pp_print_space fmt (); - extract_expr true arg; - if inside then F.pp_print_string fmt ")" - -let fstar_extract_binop (extract_expr : bool -> texpression -> unit) - (fmt : F.formatter) (inside : bool) (binop : E.binop) - (int_ty : integer_type) (arg0 : texpression) (arg1 : texpression) : unit = - if inside then F.pp_print_string fmt "("; - (* Some binary operations have a special treatment *) - (match binop with - | Eq | Lt | Le | Ne | Ge | Gt -> - let binop = - match binop with - | Eq -> "=" - | Lt -> "<" - | Le -> "<=" - | Ne -> "<>" - | Ge -> ">=" - | Gt -> ">" - | _ -> raise (Failure "Unreachable") - in - extract_expr false arg0; - F.pp_print_space fmt (); - F.pp_print_string fmt binop; - F.pp_print_space fmt (); - extract_expr false arg1 - | Div | Rem | Add | Sub | Mul -> - let binop = fstar_named_binop_name binop int_ty in - F.pp_print_string fmt binop; - F.pp_print_space fmt (); - extract_expr false arg0; - F.pp_print_space fmt (); - extract_expr false arg1 - | BitXor | BitAnd | BitOr | Shl | Shr -> raise Unimplemented); - if inside then F.pp_print_string fmt ")" - -(** - [ctx]: we use the context to lookup type definitions, to retrieve type names. - This is used to compute variable names, when they have no basenames: in this - case we use the first letter of the type name. - - [variant_concatenate_type_name]: if true, add the type name as a prefix - to the variant names. - Ex.: - In Rust: - {[ - enum List = { - Cons(u32, Box),x - Nil, - } - ]} - - F*, if option activated: - {[ - type list = - | ListCons : u32 -> list -> list - | ListNil : list - ]} - - F*, if option not activated: - {[ - type list = - | Cons : u32 -> list -> list - | Nil : list - ]} - - Rk.: this should be true by default, because in Rust all the variant names - are actively uniquely identifier by the type name [List::Cons(...)], while - in other languages it is not necessarily the case, and thus clashes can mess - up type checking. Note that some languages actually forbids the name clashes - (it is the case of F* ). - *) -let mk_formatter (ctx : trans_ctx) (crate_name : string) - (variant_concatenate_type_name : bool) : formatter = - let int_name = fstar_int_name in - - (* Prepare a name. - * The first id elem is always the crate: if it is the local crate, - * we remove it. - * We also remove all the disambiguators, then convert everything to strings. - * **Rmk:** because we remove the disambiguators, there may be name collisions - * (which is ok, because we check for name collisions and fail if there is any). - *) - let get_name (name : name) : string list = - (* Rmk.: initially we only filtered the disambiguators equal to 0 *) - let name = Names.filter_disambiguators name in - match name with - | Ident crate :: name -> - let name = if crate = crate_name then name else Ident crate :: name in - let name = - List.map - (function - | Names.Ident s -> s - | Disambiguator d -> Names.Disambiguator.to_string d) - name - in - name - | _ -> - raise (Failure ("Unexpected name shape: " ^ Print.name_to_string name)) - in - let get_type_name = get_name in - let type_name_to_camel_case name = - let name = get_type_name name in - let name = List.map to_camel_case name in - String.concat "" name - in - let type_name_to_snake_case name = - let name = get_type_name name in - let name = List.map to_snake_case name in - String.concat "_" name - in - let type_name name = type_name_to_snake_case name ^ "_t" in - let field_name (def_name : name) (field_id : FieldId.id) - (field_name : string option) : string = - let def_name = type_name_to_snake_case def_name ^ "_" in - match field_name with - | Some field_name -> def_name ^ field_name - | None -> def_name ^ FieldId.to_string field_id - in - let variant_name (def_name : name) (variant : string) : string = - let variant = to_camel_case variant in - if variant_concatenate_type_name then - type_name_to_camel_case def_name ^ variant - else variant - in - let struct_constructor (basename : name) : string = - let tname = type_name basename in - "Mk" ^ tname - in - let get_fun_name = get_name in - let fun_name_to_snake_case (fname : fun_name) : string = - let fname = get_fun_name fname in - (* Converting to snake case should be a no-op, but it doesn't cost much *) - let fname = List.map to_snake_case fname in - (* Concatenate the elements *) - String.concat "_" fname - in - let global_name (name : global_name) : string = - (* Converting to snake case also lowercases the letters (in Rust, global - * names are written in capital letters). *) - let parts = List.map to_snake_case (get_name name) in - String.concat "_" parts - in - let fun_name (_fid : A.fun_id) (fname : fun_name) (num_rgs : int) - (rg : region_group_info option) (filter_info : bool * int) : string = - let fname = fun_name_to_snake_case fname in - (* Compute the suffix *) - let suffix = default_fun_suffix num_rgs rg filter_info in - (* Concatenate *) - fname ^ suffix - in - - let decreases_clause_name (_fid : A.FunDeclId.id) (fname : fun_name) : string - = - let fname = fun_name_to_snake_case fname in - (* Compute the suffix *) - let suffix = "_decreases" in - (* Concatenate *) - fname ^ suffix - in - - let var_basename (_varset : StringSet.t) (basename : string option) (ty : ty) - : string = - (* If there is a basename, we use it *) - match basename with - | Some basename -> - (* This should be a no-op *) - to_snake_case basename - | None -> ( - (* No basename: we use the first letter of the type *) - match ty with - | Adt (type_id, tys) -> ( - match type_id with - | Tuple -> - (* The "pair" case is frequent enough to have its special treatment *) - if List.length tys = 2 then "p" else "t" - | Assumed Result -> "r" - | Assumed Option -> "opt" - | Assumed Vec -> "v" - | Assumed State -> "st" - | AdtId adt_id -> - let def = - TypeDeclId.Map.find adt_id ctx.type_context.type_decls - in - (* We do the following: - * - compute the type name, and retrieve the last ident - * - convert this to snake case - * - take the first letter of every "letter group" - * Ex.: ["hashmap"; "HashMap"] ~~> "HashMap" -> "hash_map" -> "hm" - *) - (* Thename shouldn't be empty, and its last element should - * be an ident *) - let cl = List.nth def.name (List.length def.name - 1) in - let cl = to_snake_case (Names.as_ident cl) in - let cl = String.split_on_char '_' cl in - let cl = List.filter (fun s -> String.length s > 0) cl in - assert (List.length cl > 0); - let cl = List.map (fun s -> s.[0]) cl in - StringUtils.string_of_chars cl) - | TypeVar _ -> "x" (* lacking imagination here... *) - | Bool -> "b" - | Char -> "c" - | Integer _ -> "i" - | Str -> "s" - | Arrow _ -> "f" - | Array _ | Slice _ -> raise Unimplemented) - in - let type_var_basename (_varset : StringSet.t) (basename : string) : string = - (* This is *not* a no-op: type variables in Rust often start with - * a capital letter *) - to_snake_case basename - in - let append_index (basename : string) (i : int) : string = - basename ^ string_of_int i - in - - let extract_constant_value (fmt : F.formatter) (_inside : bool) - (cv : constant_value) : unit = - match cv with - | Scalar sv -> F.pp_print_string fmt (Z.to_string sv.V.value) - | Bool b -> - let b = if b then "true" else "false" in - F.pp_print_string fmt b - | Char c -> F.pp_print_string fmt ("'" ^ String.make 1 c ^ "'") - | String s -> - (* We need to replace all the line breaks *) - let s = - StringUtils.map - (fun c -> if c = '\n' then "\n" else String.make 1 c) - s - in - F.pp_print_string fmt ("\"" ^ s ^ "\"") - in - { - bool_name = "bool"; - char_name = "char"; - int_name; - str_name = "string"; - field_name; - variant_name; - struct_constructor; - type_name; - global_name; - fun_name; - decreases_clause_name; - var_basename; - type_var_basename; - append_index; - extract_constant_value; - extract_unop = fstar_extract_unop; - extract_binop = fstar_extract_binop; - } - -(** [inside] constrols whether we should add parentheses or not around type - application (if [true] we add parentheses). - *) -let rec extract_ty (ctx : extraction_ctx) (fmt : F.formatter) (inside : bool) - (ty : ty) : unit = - match ty with - | Adt (type_id, tys) -> ( - match type_id with - | Tuple -> - (* This is a bit annoying, but in F* [()] is not the unit type: - * we have to write [unit]... *) - if tys = [] then F.pp_print_string fmt "unit" - else ( - F.pp_print_string fmt "("; - Collections.List.iter_link - (fun () -> - F.pp_print_space fmt (); - F.pp_print_string fmt "&"; - F.pp_print_space fmt ()) - (extract_ty ctx fmt true) tys; - F.pp_print_string fmt ")") - | AdtId _ | Assumed _ -> - let print_paren = inside && tys <> [] in - if print_paren then F.pp_print_string fmt "("; - F.pp_print_string fmt (ctx_get_type type_id ctx); - if tys <> [] then F.pp_print_space fmt (); - Collections.List.iter_link (F.pp_print_space fmt) - (extract_ty ctx fmt true) tys; - if print_paren then F.pp_print_string fmt ")") - | TypeVar vid -> F.pp_print_string fmt (ctx_get_type_var vid ctx) - | Bool -> F.pp_print_string fmt ctx.fmt.bool_name - | Char -> F.pp_print_string fmt ctx.fmt.char_name - | Integer int_ty -> F.pp_print_string fmt (ctx.fmt.int_name int_ty) - | Str -> F.pp_print_string fmt ctx.fmt.str_name - | Arrow (arg_ty, ret_ty) -> - if inside then F.pp_print_string fmt "("; - extract_ty ctx fmt false arg_ty; - F.pp_print_space fmt (); - F.pp_print_string fmt "->"; - F.pp_print_space fmt (); - extract_ty ctx fmt false ret_ty; - if inside then F.pp_print_string fmt ")" - | Array _ | Slice _ -> raise Unimplemented - -(** Compute the names for all the top-level identifiers used in a type - definition (type name, variant names, field names, etc. but not type - parameters). - - We need to do this preemptively, beforce extracting any definition, - because of recursive definitions. - *) -let extract_type_decl_register_names (ctx : extraction_ctx) (def : type_decl) : - extraction_ctx = - (* Compute and register the type def name *) - let ctx = ctx_add_type_decl def ctx in - (* Compute and register: - * - the variant names, if this is an enumeration - * - the field names, if this is a structure - *) - let ctx = - match def.kind with - | Struct fields -> - (* Add the fields *) - let ctx = - fst - (ctx_add_fields def (FieldId.mapi (fun id f -> (id, f)) fields) ctx) - in - (* Add the constructor name *) - fst (ctx_add_struct def ctx) - | Enum variants -> - fst - (ctx_add_variants def - (VariantId.mapi (fun id v -> (id, v)) variants) - ctx) - | Opaque -> - (* Nothing to do *) - ctx - in - (* Return *) - ctx - -let extract_type_decl_struct_body (ctx : extraction_ctx) (fmt : F.formatter) - (def : type_decl) (fields : field list) : unit = - (* We want to generate a definition which looks like this: - {[ - type t = { x : int; y : bool; } - ]} - - If there isn't enough space on one line: - {[ - type t = - { - x : int; y : bool; - } - ]} - - And if there is even less space: - {[ - type t = - { - x : int; - y : bool; - } - ]} - - Also, in case there are no fields, we need to define the type as [unit] - ([type t = {}] doesn't work in F* ). - *) - (* Note that we already printed: [type t =] *) - if fields = [] then ( - F.pp_print_space fmt (); - F.pp_print_string fmt "unit") - else ( - F.pp_print_space fmt (); - F.pp_print_string fmt "{"; - F.pp_print_break fmt 1 ctx.indent_incr; - (* The body itself *) - F.pp_open_hvbox fmt 0; - (* Print the fields *) - let print_field (field_id : FieldId.id) (f : field) : unit = - let field_name = ctx_get_field (AdtId def.def_id) field_id ctx in - F.pp_open_box fmt ctx.indent_incr; - F.pp_print_string fmt field_name; - F.pp_print_space fmt (); - F.pp_print_string fmt ":"; - F.pp_print_space fmt (); - extract_ty ctx fmt false f.field_ty; - F.pp_print_string fmt ";"; - F.pp_close_box fmt () - in - let fields = FieldId.mapi (fun fid f -> (fid, f)) fields in - Collections.List.iter_link (F.pp_print_space fmt) - (fun (fid, f) -> print_field fid f) - fields; - (* Close *) - F.pp_close_box fmt (); - F.pp_print_space fmt (); - F.pp_print_string fmt "}") - -let extract_type_decl_enum_body (ctx : extraction_ctx) (fmt : F.formatter) - (def : type_decl) (def_name : string) (type_params : string list) - (variants : variant list) : unit = - (* We want to generate a definition which looks like this: - {[ - type list a = | Cons : a -> list a -> list a | Nil : list a - ]} - - If there isn't enough space on one line: - {[ - type s = - | Cons : a -> list a -> list a - | Nil : list a - ]} - - And if we need to write the type of a variant on several lines: - {[ - type s = - | Cons : - a -> - list a -> - list a - | Nil : list a - ]} - - Finally, it is possible to give names to the variant fields in Rust. - In this situation, we generate a definition like this: - {[ - type s = - | Cons : hd:a -> tl:list a -> list a - | Nil : list a - ]} - - Note that we already printed: [type s =] - *) - (* Print the variants *) - let print_variant (variant_id : VariantId.id) (variant : variant) : unit = - let variant_name = ctx_get_variant (AdtId def.def_id) variant_id ctx in - F.pp_print_space fmt (); - F.pp_open_hvbox fmt ctx.indent_incr; - (* variant box *) - (* [| Cons :] - * Note that we really don't want any break above so we print everything - * at once. *) - F.pp_print_string fmt ("| " ^ variant_name ^ " :"); - F.pp_print_space fmt (); - let print_field (fid : FieldId.id) (f : field) (ctx : extraction_ctx) : - extraction_ctx = - (* Open the field box *) - F.pp_open_box fmt ctx.indent_incr; - (* Print the field names - * [ x :] - * Note that when printing fields, we register the field names as - * *variables*: they don't need to be unique at the top level. *) - let ctx = - match f.field_name with - | None -> ctx - | Some field_name -> - let var_id = VarId.of_int (FieldId.to_int fid) in - let field_name = - ctx.fmt.var_basename ctx.names_map.names_set (Some field_name) - f.field_ty - in - let ctx, field_name = ctx_add_var field_name var_id ctx in - F.pp_print_string fmt (field_name ^ " :"); - F.pp_print_space fmt (); - ctx - in - (* Print the field type *) - extract_ty ctx fmt false f.field_ty; - (* Print the arrow [->]*) - F.pp_print_space fmt (); - F.pp_print_string fmt "->"; - (* Close the field box *) - F.pp_close_box fmt (); - F.pp_print_space fmt (); - (* Return *) - ctx - in - (* Print the fields *) - let fields = FieldId.mapi (fun fid f -> (fid, f)) variant.fields in - let _ = - List.fold_left (fun ctx (fid, f) -> print_field fid f ctx) ctx fields - in - (* Print the final type *) - F.pp_open_hovbox fmt 0; - F.pp_print_string fmt def_name; - List.iter - (fun type_param -> - F.pp_print_space fmt (); - F.pp_print_string fmt type_param) - type_params; - F.pp_close_box fmt (); - (* Close the variant box *) - F.pp_close_box fmt () - in - (* Print the variants *) - let variants = VariantId.mapi (fun vid v -> (vid, v)) variants in - List.iter (fun (vid, v) -> print_variant vid v) variants - -(** Extract a type declaration. - - Note that all the names used for extraction should already have been - registered. - *) -let extract_type_decl (ctx : extraction_ctx) (fmt : F.formatter) - (qualif : type_decl_qualif) (def : type_decl) : unit = - (* Retrieve the definition name *) - let def_name = ctx_get_local_type def.def_id ctx in - (* Add the type params - note that we need those bindings only for the - * body translation (they are not top-level) *) - let ctx_body, type_params = ctx_add_type_params def.type_params ctx in - (* Add a break before *) - F.pp_print_break fmt 0 0; - (* Print a comment to link the extracted type to its original rust definition *) - F.pp_print_string fmt ("(** [" ^ Print.name_to_string def.name ^ "] *)"); - F.pp_print_space fmt (); - (* Open a box for the definition, so that whenever possible it gets printed on - * one line *) - F.pp_open_hvbox fmt 0; - (* Open a box for "type TYPE_NAME (TYPE_PARAMS) =" *) - F.pp_open_hovbox fmt ctx.indent_incr; - (* > "type TYPE_NAME" *) - let extract_body, qualif = - match qualif with - | Type -> (true, "type") - | And -> (true, "and") - | AssumeType -> (false, "assume type") - | TypeVal -> (false, "val") - in - F.pp_print_string fmt (qualif ^ " " ^ def_name); - (* Print the type parameters *) - if def.type_params <> [] then ( - F.pp_print_space fmt (); - F.pp_print_string fmt "("; - List.iter - (fun (p : type_var) -> - let pname = ctx_get_type_var p.index ctx_body in - F.pp_print_string fmt pname; - F.pp_print_space fmt ()) - def.type_params; - F.pp_print_string fmt ":"; - F.pp_print_space fmt (); - F.pp_print_string fmt "Type0)"); - (* Print the "=" if we extract the body*) - if extract_body then ( - F.pp_print_space fmt (); - F.pp_print_string fmt "=") - else ( - (* Otherwise print ": Type0" *) - F.pp_print_space fmt (); - F.pp_print_string fmt ":"; - F.pp_print_space fmt (); - F.pp_print_string fmt "Type0"); - (* Close the box for "type TYPE_NAME (TYPE_PARAMS) =" *) - F.pp_close_box fmt (); - (if extract_body then - match def.kind with - | Struct fields -> extract_type_decl_struct_body ctx_body fmt def fields - | Enum variants -> - extract_type_decl_enum_body ctx_body fmt def def_name type_params - variants - | Opaque -> raise (Failure "Unreachable")); - (* Close the box for the definition *) - F.pp_close_box fmt (); - (* Add breaks to insert new lines between definitions *) - F.pp_print_break fmt 0 0 - -(** Extract the state type declaration. *) -let extract_state_type (fmt : F.formatter) (ctx : extraction_ctx) - (qualif : type_decl_qualif) : unit = - (* Add a break before *) - F.pp_print_break fmt 0 0; - (* Print a comment *) - F.pp_print_string fmt "(** The state type used in the state-error monad *)"; - F.pp_print_space fmt (); - (* Open a box for the definition, so that whenever possible it gets printed on - * one line *) - F.pp_open_hvbox fmt 0; - (* Retrieve the name *) - let state_name = ctx_get_assumed_type State ctx in - (* The qualif should be [AssumeType] or [TypeVal] *) - (match qualif with - | Type | And -> raise (Failure "Unexpected") - | AssumeType -> - F.pp_print_string fmt "assume"; - F.pp_print_space fmt (); - F.pp_print_string fmt "type"; - F.pp_print_space fmt (); - F.pp_print_string fmt state_name; - F.pp_print_space fmt (); - F.pp_print_string fmt ":"; - F.pp_print_space fmt (); - F.pp_print_string fmt "Type0" - | TypeVal -> - F.pp_print_string fmt "val"; - F.pp_print_space fmt (); - F.pp_print_string fmt state_name; - F.pp_print_space fmt (); - F.pp_print_string fmt ":"; - F.pp_print_space fmt (); - F.pp_print_string fmt "Type0"); - (* Close the box for the definition *) - F.pp_close_box fmt (); - (* Add breaks to insert new lines between definitions *) - F.pp_print_break fmt 0 0 - -(** Compute the names for all the pure functions generated from a rust function - (forward function and backward functions). - *) -let extract_fun_decl_register_names (ctx : extraction_ctx) (keep_fwd : bool) - (has_decreases_clause : bool) (def : pure_fun_translation) : extraction_ctx - = - let fwd, back_ls = def in - (* Register the decrease clause, if necessary *) - let ctx = - if has_decreases_clause then ctx_add_decrases_clause fwd ctx else ctx - in - (* Register the forward function name *) - let ctx = ctx_add_fun_decl (keep_fwd, def) fwd ctx in - (* Register the backward functions' names *) - let ctx = - List.fold_left - (fun ctx back -> ctx_add_fun_decl (keep_fwd, def) back ctx) - ctx back_ls - in - (* Return *) - ctx - -(** Simply add the global name to the context. *) -let extract_global_decl_register_names (ctx : extraction_ctx) - (def : A.global_decl) : extraction_ctx = - ctx_add_global_decl_and_body def ctx - -(** The following function factorizes the extraction of ADT values. - - Note that patterns can introduce new variables: we thus return an extraction - context updated with new bindings. - - TODO: we don't need something very generic anymore - *) -let extract_adt_g_value - (extract_value : extraction_ctx -> bool -> 'v -> extraction_ctx) - (fmt : F.formatter) (ctx : extraction_ctx) (inside : bool) - (variant_id : VariantId.id option) (field_values : 'v list) (ty : ty) : - extraction_ctx = - match ty with - | Adt (Tuple, _) -> - (* Tuple *) - F.pp_print_string fmt "("; - let ctx = - Collections.List.fold_left_link - (fun () -> - F.pp_print_string fmt ","; - F.pp_print_space fmt ()) - (fun ctx v -> extract_value ctx false v) - ctx field_values - in - F.pp_print_string fmt ")"; - ctx - | Adt (adt_id, _) -> - (* "Regular" ADT *) - (* We print something of the form: [Cons field0 ... fieldn]. - * We could update the code to print something of the form: - * [{ field0=...; ...; fieldn=...; }] in case of structures. - *) - let cons = - match variant_id with - | Some vid -> ctx_get_variant adt_id vid ctx - | None -> ctx_get_struct adt_id ctx - in - if inside && field_values <> [] then F.pp_print_string fmt "("; - F.pp_print_string fmt cons; - let ctx = - Collections.List.fold_left - (fun ctx v -> - F.pp_print_space fmt (); - extract_value ctx true v) - ctx field_values - in - if inside && field_values <> [] then F.pp_print_string fmt ")"; - ctx - | _ -> raise (Failure "Inconsistent typed value") - -(* Extract globals in the same way as variables *) -let extract_global (ctx : extraction_ctx) (fmt : F.formatter) - (id : A.GlobalDeclId.id) : unit = - F.pp_print_string fmt (ctx_get_global id ctx) - -(** [inside]: see [extract_ty]. - - As a pattern can introduce new variables, we return an extraction context - updated with new bindings. - *) -let rec extract_typed_pattern (ctx : extraction_ctx) (fmt : F.formatter) - (inside : bool) (v : typed_pattern) : extraction_ctx = - match v.value with - | PatConcrete cv -> - ctx.fmt.extract_constant_value fmt inside cv; - ctx - | PatVar (v, _) -> - let vname = - ctx.fmt.var_basename ctx.names_map.names_set v.basename v.ty - in - let ctx, vname = ctx_add_var vname v.id ctx in - F.pp_print_string fmt vname; - ctx - | PatDummy -> - F.pp_print_string fmt "_"; - ctx - | PatAdt av -> - let extract_value ctx inside v = extract_typed_pattern ctx fmt inside v in - extract_adt_g_value extract_value fmt ctx inside av.variant_id - av.field_values v.ty - -(** [inside]: controls the introduction of parentheses. See [extract_ty] - - TODO: replace the formatting boolean [inside] with something more general? - Also, it seems we don't really use it... - Cases to consider: - - right-expression in a let: [let x = re in _] (never parentheses?) - - next expression in a let: [let x = _ in next_e] (never parentheses?) - - application argument: [f (exp)] - - match/if scrutinee: [if exp then _ else _]/[match exp | _ -> _] - *) -let rec extract_texpression (ctx : extraction_ctx) (fmt : F.formatter) - (inside : bool) (e : texpression) : unit = - match e.e with - | Var var_id -> - let var_name = ctx_get_var var_id ctx in - F.pp_print_string fmt var_name - | Const cv -> ctx.fmt.extract_constant_value fmt inside cv - | App _ -> - let app, args = destruct_apps e in - extract_App ctx fmt inside app args - | Abs _ -> - let xl, e = destruct_abs_list e in - extract_Abs ctx fmt inside xl e - | Qualif _ -> - (* We use the app case *) - extract_App ctx fmt inside e [] - | Let (monadic, lv, re, next_e) -> - extract_Let ctx fmt inside monadic lv re next_e - | Switch (scrut, body) -> extract_Switch ctx fmt inside scrut body - | Meta (_, e) -> extract_texpression ctx fmt inside e - -(* Extract an application *or* a top-level qualif (function extraction has - * to handle top-level qualifiers, so it seemed more natural to merge the - * two cases) *) -and extract_App (ctx : extraction_ctx) (fmt : F.formatter) (inside : bool) - (app : texpression) (args : texpression list) : unit = - (* We don't do the same thing if the app is a top-level identifier (function, - * ADT constructor...) or a "regular" expression *) - match app.e with - | Qualif qualif -> ( - (* Top-level qualifier *) - match qualif.id with - | Func fun_id -> - extract_function_call ctx fmt inside fun_id qualif.type_args args - | Global global_id -> extract_global ctx fmt global_id - | AdtCons adt_cons_id -> - extract_adt_cons ctx fmt inside adt_cons_id qualif.type_args args - | Proj proj -> - extract_field_projector ctx fmt inside app proj qualif.type_args args) - | _ -> - (* "Regular" expression *) - (* Open parentheses *) - if inside then F.pp_print_string fmt "("; - (* Open a box for the application *) - F.pp_open_hovbox fmt ctx.indent_incr; - (* Print the app expression *) - let app_inside = (inside && args = []) || args <> [] in - extract_texpression ctx fmt app_inside app; - (* Print the arguments *) - List.iter - (fun ve -> - F.pp_print_space fmt (); - extract_texpression ctx fmt true ve) - args; - (* Close the box for the application *) - F.pp_close_box fmt (); - (* Close parentheses *) - if inside then F.pp_print_string fmt ")" - -(** Subcase of the app case: function call *) -and extract_function_call (ctx : extraction_ctx) (fmt : F.formatter) - (inside : bool) (fid : fun_id) (type_args : ty list) - (args : texpression list) : unit = - match (fid, args) with - | Unop unop, [ arg ] -> - (* A unop can have *at most* one argument (the result can't be a function!). - * Note that the way we generate the translation, we shouldn't get the - * case where we have no argument (all functions are fully instantiated, - * and no AST transformation introduces partial calls). *) - ctx.fmt.extract_unop (extract_texpression ctx fmt) fmt inside unop arg - | Binop (binop, int_ty), [ arg0; arg1 ] -> - (* Number of arguments: similar to unop *) - ctx.fmt.extract_binop - (extract_texpression ctx fmt) - fmt inside binop int_ty arg0 arg1 - | Regular (fun_id, rg_id), _ -> - if inside then F.pp_print_string fmt "("; - (* Open a box for the function call *) - F.pp_open_hovbox fmt ctx.indent_incr; - (* Print the function name *) - let fun_name = ctx_get_function fun_id rg_id ctx in - F.pp_print_string fmt fun_name; - (* Print the type parameters *) - List.iter - (fun ty -> - F.pp_print_space fmt (); - extract_ty ctx fmt true ty) - type_args; - (* Print the arguments *) - List.iter - (fun ve -> - F.pp_print_space fmt (); - extract_texpression ctx fmt true ve) - args; - (* Close the box for the function call *) - F.pp_close_box fmt (); - (* Return *) - if inside then F.pp_print_string fmt ")" - | _ -> - raise - (Failure - ("Unreachable:\n" ^ "Function: " ^ show_fun_id fid - ^ ",\nNumber of arguments: " - ^ string_of_int (List.length args) - ^ ",\nArguments: " - ^ String.concat " " (List.map show_texpression args))) - -(** Subcase of the app case: ADT constructor *) -and extract_adt_cons (ctx : extraction_ctx) (fmt : F.formatter) (inside : bool) - (adt_cons : adt_cons_id) (type_args : ty list) (args : texpression list) : - unit = - match adt_cons.adt_id with - | Tuple -> - (* Tuple *) - (* For now, we only support fully applied tuple constructors *) - assert (List.length type_args = List.length args); - F.pp_print_string fmt "("; - Collections.List.iter_link - (fun () -> - F.pp_print_string fmt ","; - F.pp_print_space fmt ()) - (fun v -> extract_texpression ctx fmt false v) - args; - F.pp_print_string fmt ")" - | _ -> - (* "Regular" ADT *) - (* We print something of the form: [Cons field0 ... fieldn]. - * We could update the code to print something of the form: - * [{ field0=...; ...; fieldn=...; }] in case of fully - * applied structure constructors. - *) - let cons = - match adt_cons.variant_id with - | Some vid -> ctx_get_variant adt_cons.adt_id vid ctx - | None -> ctx_get_struct adt_cons.adt_id ctx - in - let use_parentheses = inside && args <> [] in - if use_parentheses then F.pp_print_string fmt "("; - F.pp_print_string fmt cons; - Collections.List.iter - (fun v -> - F.pp_print_space fmt (); - extract_texpression ctx fmt true v) - args; - if use_parentheses then F.pp_print_string fmt ")" - -(** Subcase of the app case: ADT field projector. *) -and extract_field_projector (ctx : extraction_ctx) (fmt : F.formatter) - (inside : bool) (original_app : texpression) (proj : projection) - (_proj_type_params : ty list) (args : texpression list) : unit = - (* We isolate the first argument (if there is), in order to pretty print the - * projection ([x.field] instead of [MkAdt?.field x] *) - match args with - | [ arg ] -> - (* Exactly one argument: pretty-print *) - let field_name = ctx_get_field proj.adt_id proj.field_id ctx in - (* Open a box *) - F.pp_open_hovbox fmt ctx.indent_incr; - (* Extract the expression *) - extract_texpression ctx fmt true arg; - (* We allow to break where the "." appears *) - F.pp_print_break fmt 0 0; - F.pp_print_string fmt "."; - F.pp_print_string fmt field_name; - (* Close the box *) - F.pp_close_box fmt () - | arg :: args -> - (* Call extract_App again, but in such a way that the first argument is - * isolated *) - extract_App ctx fmt inside (mk_app original_app arg) args - | [] -> - (* No argument: shouldn't happen *) - raise (Failure "Unreachable") - -and extract_Abs (ctx : extraction_ctx) (fmt : F.formatter) (inside : bool) - (xl : typed_pattern list) (e : texpression) : unit = - (* Open a box for the abs expression *) - F.pp_open_hovbox fmt ctx.indent_incr; - (* Open parentheses *) - if inside then F.pp_print_string fmt "("; - (* Print the lambda - note that there should always be at least one variable *) - assert (xl <> []); - F.pp_print_string fmt "fun"; - let ctx = - List.fold_left - (fun ctx x -> - F.pp_print_space fmt (); - extract_typed_pattern ctx fmt true x) - ctx xl - in - F.pp_print_space fmt (); - F.pp_print_string fmt "->"; - F.pp_print_space fmt (); - (* Print the body *) - extract_texpression ctx fmt false e; - (* Close parentheses *) - if inside then F.pp_print_string fmt ")"; - (* Close the box for the abs expression *) - F.pp_close_box fmt () - -and extract_Let (ctx : extraction_ctx) (fmt : F.formatter) (inside : bool) - (monadic : bool) (lv : typed_pattern) (re : texpression) - (next_e : texpression) : unit = - (* Open a box for the whole expression *) - F.pp_open_hvbox fmt 0; - (* Open parentheses *) - if inside then F.pp_print_string fmt "("; - (* Open a box for the let-binding *) - F.pp_open_hovbox fmt ctx.indent_incr; - let ctx = - if monadic then ( - (* Note that in F*, the left value of a monadic let-binding can only be - * a variable *) - let ctx = extract_typed_pattern ctx fmt true lv in - F.pp_print_space fmt (); - F.pp_print_string fmt "<--"; - F.pp_print_space fmt (); - extract_texpression ctx fmt false re; - F.pp_print_string fmt ";"; - ctx) - else ( - F.pp_print_string fmt "let"; - F.pp_print_space fmt (); - let ctx = extract_typed_pattern ctx fmt true lv in - F.pp_print_space fmt (); - F.pp_print_string fmt "="; - F.pp_print_space fmt (); - extract_texpression ctx fmt false re; - F.pp_print_space fmt (); - F.pp_print_string fmt "in"; - ctx) - in - (* Close the box for the let-binding *) - F.pp_close_box fmt (); - (* Print the next expression *) - F.pp_print_space fmt (); - extract_texpression ctx fmt false next_e; - (* Close parentheses *) - if inside then F.pp_print_string fmt ")"; - (* Close the box for the whole expression *) - F.pp_close_box fmt () - -and extract_Switch (ctx : extraction_ctx) (fmt : F.formatter) (inside : bool) - (scrut : texpression) (body : switch_body) : unit = - (* Open a box for the whole expression *) - F.pp_open_hvbox fmt 0; - (* Open parentheses *) - if inside then F.pp_print_string fmt "("; - (* Extract the switch *) - (match body with - | If (e_then, e_else) -> - (* Open a box for the [if] *) - F.pp_open_hovbox fmt ctx.indent_incr; - F.pp_print_string fmt "if"; - F.pp_print_space fmt (); - let scrut_inside = PureUtils.let_group_requires_parentheses scrut in - extract_texpression ctx fmt scrut_inside scrut; - (* Close the box for the [if] *) - F.pp_close_box fmt (); - (* Extract the branches *) - let extract_branch (is_then : bool) (e_branch : texpression) : unit = - F.pp_print_space fmt (); - (* Open a box for the then/else+branch *) - F.pp_open_hovbox fmt ctx.indent_incr; - let then_or_else = if is_then then "then" else "else" in - F.pp_print_string fmt then_or_else; - F.pp_print_space fmt (); - (* Open a box for the branch *) - F.pp_open_hovbox fmt ctx.indent_incr; - (* Print the [begin] if necessary *) - let parenth = PureUtils.let_group_requires_parentheses e_branch in - if parenth then ( - F.pp_print_string fmt "begin"; - F.pp_print_space fmt ()); - (* Print the branch expression *) - extract_texpression ctx fmt false e_branch; - (* Close the [begin ... end ] *) - if parenth then ( - F.pp_print_space fmt (); - F.pp_print_string fmt "end"); - (* Close the box for the branch *) - F.pp_close_box fmt (); - (* Close the box for the then/else+branch *) - F.pp_close_box fmt () - in - - extract_branch true e_then; - extract_branch false e_else - | Match branches -> - (* Open a box for the [match ... with] *) - F.pp_open_hovbox fmt ctx.indent_incr; - (* Print the [match ... with] *) - F.pp_print_string fmt "begin match"; - F.pp_print_space fmt (); - let scrut_inside = PureUtils.let_group_requires_parentheses scrut in - extract_texpression ctx fmt scrut_inside scrut; - F.pp_print_space fmt (); - F.pp_print_string fmt "with"; - (* Close the box for the [match ... with] *) - F.pp_close_box fmt (); - - (* Extract the branches *) - let extract_branch (br : match_branch) : unit = - F.pp_print_space fmt (); - (* Open a box for the pattern+branch *) - F.pp_open_hovbox fmt ctx.indent_incr; - F.pp_print_string fmt "|"; - (* Print the pattern *) - F.pp_print_space fmt (); - let ctx = extract_typed_pattern ctx fmt false br.pat in - F.pp_print_space fmt (); - F.pp_print_string fmt "->"; - F.pp_print_space fmt (); - (* Open a box for the branch *) - F.pp_open_hovbox fmt ctx.indent_incr; - (* Print the branch itself *) - extract_texpression ctx fmt false br.branch; - (* Close the box for the branch *) - F.pp_close_box fmt (); - (* Close the box for the pattern+branch *) - F.pp_close_box fmt () - in - - List.iter extract_branch branches; - - (* End the match *) - F.pp_print_space fmt (); - F.pp_print_string fmt "end"); - (* Close parentheses *) - if inside then F.pp_print_string fmt ")"; - (* Close the box for the whole expression *) - F.pp_close_box fmt () - -(** A small utility to print the parameters of a function signature. - - We return two contexts: - - the context augmented with bindings for the type parameters - - the previous context augmented with bindings for the input values - *) -let extract_fun_parameters (ctx : extraction_ctx) (fmt : F.formatter) - (def : fun_decl) : extraction_ctx * extraction_ctx = - (* Add the type parameters - note that we need those bindings only for the - * body translation (they are not top-level) *) - let ctx, _ = ctx_add_type_params def.signature.type_params ctx in - (* Print the parameters - rk.: we should have filtered the functions - * with no input parameters *) - (* The type parameters *) - if def.signature.type_params <> [] then ( - (* Open a box for the type parameters *) - F.pp_open_hovbox fmt 0; - F.pp_print_string fmt "("; - List.iter - (fun (p : type_var) -> - let pname = ctx_get_type_var p.index ctx in - F.pp_print_string fmt pname; - F.pp_print_space fmt ()) - def.signature.type_params; - F.pp_print_string fmt ":"; - F.pp_print_space fmt (); - F.pp_print_string fmt "Type0)"; - (* Close the box for the type parameters *) - F.pp_close_box fmt (); - F.pp_print_space fmt ()); - (* The input parameters - note that doing this adds bindings to the context *) - let ctx_body = - match def.body with - | None -> ctx - | Some body -> - List.fold_left - (fun ctx (lv : typed_pattern) -> - (* Open a box for the input parameter *) - F.pp_open_hovbox fmt 0; - F.pp_print_string fmt "("; - let ctx = extract_typed_pattern ctx fmt false lv in - F.pp_print_space fmt (); - F.pp_print_string fmt ":"; - F.pp_print_space fmt (); - extract_ty ctx fmt false lv.ty; - F.pp_print_string fmt ")"; - (* Close the box for the input parameters *) - F.pp_close_box fmt (); - F.pp_print_space fmt (); - ctx) - ctx body.inputs_lvs - in - (ctx, ctx_body) - -(** A small utility to print the types of the input parameters in the form: - [u32 -> list u32 -> ...] - (we don't print the return type of the function) - - This is used for opaque function declarations, in particular. - *) -let extract_fun_input_parameters_types (ctx : extraction_ctx) - (fmt : F.formatter) (def : fun_decl) : unit = - let extract_param (ty : ty) : unit = - let inside = false in - extract_ty ctx fmt inside ty; - F.pp_print_space fmt (); - F.pp_print_string fmt "->"; - F.pp_print_space fmt () - in - List.iter extract_param def.signature.inputs - -(** Extract a decrease clause function template body. - - In order to help the user, we can generate a template for the functions - required by the decreases clauses. We simply generate definitions of - the following form in a separate file: - {[ - let f_decrease (t : Type0) (x : t) : nat = admit() - ]} - - Where the translated functions for [f] look like this: - {[ - let f_fwd (t : Type0) (x : t) : Tot ... (decreases (f_decrease t x)) = ... - ]} - *) -let extract_template_decreases_clause (ctx : extraction_ctx) (fmt : F.formatter) - (def : fun_decl) : unit = - (* Retrieve the function name *) - let def_name = ctx_get_decreases_clause def.def_id ctx in - (* Add a break before *) - F.pp_print_break fmt 0 0; - (* Print a comment to link the extracted type to its original rust definition *) - F.pp_print_string fmt - ("(** [" ^ Print.fun_name_to_string def.basename ^ "]: decreases clause *)"); - F.pp_print_space fmt (); - (* Open a box for the definition, so that whenever possible it gets printed on - * one line *) - F.pp_open_hvbox fmt 0; - (* Add the [unfold] keyword *) - F.pp_print_string fmt "unfold"; - F.pp_print_space fmt (); - (* Open a box for "let FUN_NAME (PARAMS) : EFFECT = admit()" *) - F.pp_open_hvbox fmt ctx.indent_incr; - (* Open a box for "let FUN_NAME (PARAMS) : EFFECT =" *) - F.pp_open_hovbox fmt ctx.indent_incr; - (* > "let FUN_NAME" *) - F.pp_print_string fmt ("let " ^ def_name); - F.pp_print_space fmt (); - (* Extract the parameters *) - let _, _ = extract_fun_parameters ctx fmt def in - F.pp_print_string fmt ":"; - (* Print the signature *) - F.pp_print_space fmt (); - F.pp_print_string fmt "nat"; - (* Print the "=" *) - F.pp_print_space fmt (); - F.pp_print_string fmt "="; - (* Close the box for "let FUN_NAME (PARAMS) : EFFECT =" *) - F.pp_close_box fmt (); - F.pp_print_space fmt (); - (* Print the "admit ()" *) - F.pp_print_string fmt "admit ()"; - (* Close the box for "let FUN_NAME (PARAMS) : EFFECT = admit()" *) - F.pp_close_box fmt (); - (* Close the box for the whole definition *) - F.pp_close_box fmt (); - (* Add breaks to insert new lines between definitions *) - F.pp_print_break fmt 0 0 - -(** Extract a function declaration. - - Note that all the names used for extraction should already have been - registered. - - We take the definition of the forward translation as parameter (which is - equal to the definition to extract, if we extract a forward function) because - it is useful for the decrease clause. - *) -let extract_fun_decl (ctx : extraction_ctx) (fmt : F.formatter) - (qualif : fun_decl_qualif) (has_decreases_clause : bool) (def : fun_decl) : - unit = - assert (not def.is_global_decl_body); - (* Retrieve the function name *) - let def_name = ctx_get_local_function def.def_id def.back_id ctx in - (* (* Add the type parameters - note that we need those bindings only for the - * body translation (they are not top-level) *) - let ctx, _ = ctx_add_type_params def.signature.type_params ctx in *) - (* Add a break before *) - F.pp_print_break fmt 0 0; - (* Print a comment to link the extracted type to its original rust definition *) - F.pp_print_string fmt - ("(** [" ^ Print.fun_name_to_string def.basename ^ "] *)"); - F.pp_print_space fmt (); - (* Open a box for the definition, so that whenever possible it gets printed on - * one line *) - F.pp_open_hvbox fmt ctx.indent_incr; - (* Open a box for "let FUN_NAME (PARAMS) : EFFECT =" *) - F.pp_open_hovbox fmt ctx.indent_incr; - (* > "let FUN_NAME" *) - let is_opaque = Option.is_none def.body in - let qualif = fun_decl_qualif_keyword qualif in - F.pp_print_string fmt (qualif ^ " " ^ def_name); - F.pp_print_space fmt (); - (* Open a box for "(PARAMS) : EFFECT =" *) - F.pp_open_hvbox fmt 0; - (* Open a box for "(PARAMS)" *) - F.pp_open_hovbox fmt 0; - let ctx, ctx_body = extract_fun_parameters ctx fmt def in - (* Close the box for "(PARAMS)" *) - F.pp_close_box fmt (); - (* Print the return type - note that we have to be careful when - * printing the input values for the decrease clause, because - * it introduces bindings in the context... We thus "forget" - * the bindings we introduced above. - * TODO: figure out a cleaner way *) - let _ = - F.pp_print_string fmt ":"; - F.pp_print_space fmt (); - (* Open a box for the EFFECT *) - F.pp_open_hvbox fmt 0; - (* Open a box for the return type *) - F.pp_open_hovbox fmt ctx.indent_incr; - (* Print the return type *) - (* For opaque definitions, as we don't have named parameters under the hand, - * we don't print parameters in the form [(x : a) (y : b) ...] above, - * but wait until here to print the types: [a -> b -> ...]. *) - if is_opaque then extract_fun_input_parameters_types ctx fmt def; - (* [Tot] *) - if has_decreases_clause then ( - F.pp_print_string fmt "Tot"; - F.pp_print_space fmt ()); - extract_ty ctx fmt has_decreases_clause def.signature.output; - (* Close the box for the return type *) - F.pp_close_box fmt (); - (* Print the decrease clause - rk.: a function with a decreases clause - * is necessarily a transparent function *) - if has_decreases_clause then ( - F.pp_print_space fmt (); - (* Open a box for the decrease clause *) - F.pp_open_hovbox fmt 0; - (* *) - F.pp_print_string fmt "(decreases"; - F.pp_print_space fmt (); - F.pp_print_string fmt "("; - (* The name of the decrease clause *) - let decr_name = ctx_get_decreases_clause def.def_id ctx in - F.pp_print_string fmt decr_name; - (* Print the type parameters *) - List.iter - (fun (p : type_var) -> - let pname = ctx_get_type_var p.index ctx in - F.pp_print_space fmt (); - F.pp_print_string fmt pname) - def.signature.type_params; - (* Print the input values: we have to be careful here to print - * only the input values which are in common with the *forward* - * function (the additional input values "given back" to the - * backward functions have no influence on termination: we thus - * share the decrease clauses between the forward and the backward - * functions). - *) - let inputs_lvs = - let all_inputs = (Option.get def.body).inputs_lvs in - (* We have to count: - * - the forward inputs - * - the state - *) - let num_fwd_inputs = def.signature.info.num_fwd_inputs in - let num_fwd_inputs = - if def.signature.info.effect_info.input_state then 1 + num_fwd_inputs - else num_fwd_inputs - in - Collections.List.prefix num_fwd_inputs all_inputs - in - let _ = - List.fold_left - (fun ctx (lv : typed_pattern) -> - F.pp_print_space fmt (); - let ctx = extract_typed_pattern ctx fmt false lv in - ctx) - ctx inputs_lvs - in - F.pp_print_string fmt "))"; - (* Close the box for the decrease clause *) - F.pp_close_box fmt ()); - (* Close the box for the EFFECT *) - F.pp_close_box fmt () - in - (* Print the "=" *) - if not is_opaque then ( - F.pp_print_space fmt (); - F.pp_print_string fmt "="); - (* Close the box for "(PARAMS) : EFFECT =" *) - F.pp_close_box fmt (); - (* Close the box for "let FUN_NAME (PARAMS) : EFFECT =" *) - F.pp_close_box fmt (); - if not is_opaque then ( - F.pp_print_space fmt (); - (* Open a box for the body *) - F.pp_open_hvbox fmt 0; - (* Extract the body *) - let _ = extract_texpression ctx_body fmt false (Option.get def.body).body in - (* Close the box for the body *) - F.pp_close_box fmt ()); - (* Close the box for the definition *) - F.pp_close_box fmt (); - (* Add breaks to insert new lines between definitions *) - F.pp_print_break fmt 0 0 - -(** Extract a global declaration body of the shape "QUALIF NAME : TYPE = BODY" with a custom body extractor *) -let extract_global_decl_body (ctx : extraction_ctx) (fmt : F.formatter) - (qualif : fun_decl_qualif) (name : string) (ty : ty) - (extract_body : (F.formatter -> unit) Option.t) : unit = - let is_opaque = Option.is_none extract_body in - - (* Open the definition box (depth=0) *) - F.pp_open_hvbox fmt ctx.indent_incr; - - (* Open "QUALIF NAME : TYPE =" box (depth=1) *) - F.pp_open_hovbox fmt ctx.indent_incr; - (* Print "QUALIF NAME " *) - F.pp_print_string fmt (fun_decl_qualif_keyword qualif ^ " " ^ name); - F.pp_print_space fmt (); - - (* Open ": TYPE =" box (depth=2) *) - F.pp_open_hvbox fmt 0; - (* Print ": " *) - F.pp_print_string fmt ":"; - F.pp_print_space fmt (); - - (* Open "TYPE" box (depth=3) *) - F.pp_open_hovbox fmt ctx.indent_incr; - (* Print "TYPE" *) - extract_ty ctx fmt false ty; - (* Close "TYPE" box (depth=3) *) - F.pp_close_box fmt (); - - if not is_opaque then ( - (* Print " =" *) - F.pp_print_space fmt (); - F.pp_print_string fmt "="); - (* Close ": TYPE =" box (depth=2) *) - F.pp_close_box fmt (); - (* Close "QUALIF NAME : TYPE =" box (depth=1) *) - F.pp_close_box fmt (); - - if not is_opaque then ( - F.pp_print_space fmt (); - (* Open "BODY" box (depth=1) *) - F.pp_open_hvbox fmt 0; - (* Print "BODY" *) - (Option.get extract_body) fmt; - (* Close "BODY" box (depth=1) *) - F.pp_close_box fmt ()); - (* Close the definition box (depth=0) *) - F.pp_close_box fmt () - -(** Extract a global declaration. - We generate the body which computes the global value separately from the value declaration itself. - - For example in Rust, - [static X: u32 = 3;] - - will be translated to: - [let x_body : result u32 = Return 3] - [let x_c : u32 = eval_global x_body] - *) -let extract_global_decl (ctx : extraction_ctx) (fmt : F.formatter) - (global : A.global_decl) (body : fun_decl) (interface : bool) : unit = - assert body.is_global_decl_body; - assert (Option.is_none body.back_id); - assert (List.length body.signature.inputs = 0); - assert (List.length body.signature.doutputs = 1); - assert (List.length body.signature.type_params = 0); - - (* Add a break then the name of the corresponding LLBC declaration *) - F.pp_print_break fmt 0 0; - F.pp_print_string fmt - ("(** [" ^ Print.global_name_to_string global.name ^ "] *)"); - F.pp_print_space fmt (); - - let decl_name = ctx_get_global global.def_id ctx in - let body_name = ctx_get_function (Regular global.body_id) None ctx in - - let decl_ty, body_ty = - let ty = body.signature.output in - if body.signature.info.effect_info.can_fail then (unwrap_result_ty ty, ty) - else (ty, mk_result_ty ty) - in - match body.body with - | None -> - let qualif = if interface then Val else AssumeVal in - extract_global_decl_body ctx fmt qualif decl_name decl_ty None - | Some body -> - extract_global_decl_body ctx fmt Let body_name body_ty - (Some (fun fmt -> extract_texpression ctx fmt false body.body)); - F.pp_print_break fmt 0 0; - extract_global_decl_body ctx fmt Let decl_name decl_ty - (Some (fun fmt -> F.pp_print_string fmt ("eval_global " ^ body_name))); - F.pp_print_break fmt 0 0 - -(** Extract a unit test, if the function is a unit function (takes no - parameters, returns unit). - - A unit test simply checks that the function normalizes to [Return ()]: - {[ - let _ = assert_norm (FUNCTION () = Return ()) - ]} - *) -let extract_unit_test_if_unit_fun (ctx : extraction_ctx) (fmt : F.formatter) - (def : fun_decl) : unit = - (* We only insert unit tests for forward functions *) - assert (def.back_id = None); - (* Check if this is a unit function *) - let sg = def.signature in - if - sg.type_params = [] - && (sg.inputs = [ mk_unit_ty ] || sg.inputs = []) - && sg.output = mk_result_ty mk_unit_ty - then ( - (* Add a break before *) - F.pp_print_break fmt 0 0; - (* Print a comment *) - F.pp_print_string fmt - ("(** Unit test for [" ^ Print.fun_name_to_string def.basename ^ "] *)"); - F.pp_print_space fmt (); - (* Open a box for the test *) - F.pp_open_hovbox fmt ctx.indent_incr; - (* Print the test *) - F.pp_print_string fmt "let _ ="; - F.pp_print_space fmt (); - F.pp_print_string fmt "assert_norm"; - F.pp_print_space fmt (); - F.pp_print_string fmt "("; - let fun_name = ctx_get_local_function def.def_id def.back_id ctx in - F.pp_print_string fmt fun_name; - if sg.inputs <> [] then ( - F.pp_print_space fmt (); - F.pp_print_string fmt "()"); - F.pp_print_space fmt (); - F.pp_print_string fmt "="; - F.pp_print_space fmt (); - let success = ctx_get_variant (Assumed Result) result_return_id ctx in - F.pp_print_string fmt (success ^ " ())"); - (* Close the box for the test *) - F.pp_close_box fmt (); - (* Add a break after *) - F.pp_print_break fmt 0 0) - else (* Do nothing *) - () diff --git a/src/FunsAnalysis.ml b/src/FunsAnalysis.ml deleted file mode 100644 index 248ad8b3..00000000 --- a/src/FunsAnalysis.ml +++ /dev/null @@ -1,143 +0,0 @@ -(** Compute various information, including: - - can a function fail (by having `Fail` in its body, or transitively - calling a function which can fail - this is false for globals) - - can a function diverge (by being recursive, containing a loop or - transitively calling a function which can diverge) - - does a function perform stateful operations (i.e., do we need a state - to translate it) - *) - -open LlbcAst -open Crates -module EU = ExpressionsUtils - -type fun_info = { - can_fail : bool; - (* Not used yet: all the extracted functions use an error monad *) - stateful : bool; - divergent : bool; (* Not used yet *) -} -[@@deriving show] -(** Various information about a function. - - Note that not all this information is used yet to adjust the extraction yet. - *) - -type modules_funs_info = fun_info FunDeclId.Map.t -(** Various information about a module's functions *) - -let analyze_module (m : llbc_crate) (funs_map : fun_decl FunDeclId.Map.t) - (globals_map : global_decl GlobalDeclId.Map.t) (use_state : bool) : - modules_funs_info = - let infos = ref FunDeclId.Map.empty in - - let register_info (id : FunDeclId.id) (info : fun_info) : unit = - assert (not (FunDeclId.Map.mem id !infos)); - infos := FunDeclId.Map.add id info !infos - in - - (* Analyze a group of mutually recursive functions. - * As the functions can call each other, we compute the same information - * for all of them (if one of the functions can fail, then all of them - * can fail, etc.). - * - * We simply check if the functions contains panic statements, loop statements, - * recursive calls, etc. We use the previously computed information in case - * of function calls. - *) - let analyze_fun_decls (fun_ids : FunDeclId.Set.t) (d : fun_decl list) : - fun_info = - let can_fail = ref false in - let stateful = ref false in - let divergent = ref false in - - let visit_fun (f : fun_decl) : unit = - let obj = - object (self) - inherit [_] iter_statement as super - method may_fail b = can_fail := !can_fail || b - - method! visit_Assert env a = - self#may_fail true; - super#visit_Assert env a - - method! visit_rvalue _env rv = - match rv with - | Use _ | Ref _ | Discriminant _ | Aggregate _ -> () - | UnaryOp (uop, _) -> can_fail := EU.unop_can_fail uop || !can_fail - | BinaryOp (bop, _, _) -> - can_fail := EU.binop_can_fail bop || !can_fail - - method! visit_Call env call = - (match call.func with - | Regular id -> - if FunDeclId.Set.mem id fun_ids then divergent := true - else - let info = FunDeclId.Map.find id !infos in - self#may_fail info.can_fail; - stateful := !stateful || info.stateful; - divergent := !divergent || info.divergent - | Assumed id -> - (* None of the assumed functions is stateful for now *) - can_fail := !can_fail || Assumed.assumed_can_fail id); - super#visit_Call env call - - method! visit_Panic env = - self#may_fail true; - super#visit_Panic env - - method! visit_Loop env loop = - divergent := true; - super#visit_Loop env loop - end - in - (* Sanity check: global bodies don't contain stateful calls *) - assert ((not f.is_global_decl_body) || not !stateful); - match f.body with - | None -> - (* Opaque function: we consider they fail by default *) - obj#may_fail true; - stateful := (not f.is_global_decl_body) && use_state - | Some body -> obj#visit_statement () body.body - in - List.iter visit_fun d; - (* We need to know if the declaration group contains a global - note that - * groups containing globals contain exactly one declaration *) - let is_global_decl_body = List.exists (fun f -> f.is_global_decl_body) d in - assert ((not is_global_decl_body) || List.length d == 1); - (* We ignore on purpose functions that cannot fail and consider they *can* - * fail: the result of the analysis is not used yet to adjust the translation - * so that the functions which syntactically can't fail don't use an error monad. - * However, we do keep the result of the analysis for global bodies. - * *) - can_fail := (not is_global_decl_body) || !can_fail; - { can_fail = !can_fail; stateful = !stateful; divergent = !divergent } - in - - let analyze_fun_decl_group (d : fun_declaration_group) : unit = - (* Retrieve the function declarations *) - let funs = match d with NonRec id -> [ id ] | Rec ids -> ids in - let funs = List.map (fun id -> FunDeclId.Map.find id funs_map) funs in - let fun_ids = List.map (fun (d : fun_decl) -> d.def_id) funs in - let fun_ids = FunDeclId.Set.of_list fun_ids in - let info = analyze_fun_decls fun_ids funs in - List.iter (fun (f : fun_decl) -> register_info f.def_id info) funs - in - - let rec analyze_decl_groups (decls : declaration_group list) : unit = - match decls with - | [] -> () - | Type _ :: decls' -> analyze_decl_groups decls' - | Fun decl :: decls' -> - analyze_fun_decl_group decl; - analyze_decl_groups decls' - | Global id :: decls' -> - (* Analyze a global by analyzing its body function *) - let global = GlobalDeclId.Map.find id globals_map in - analyze_fun_decl_group (NonRec global.body_id); - analyze_decl_groups decls' - in - - analyze_decl_groups m.declarations; - - !infos diff --git a/src/Identifiers.ml b/src/Identifiers.ml deleted file mode 100644 index b022b18d..00000000 --- a/src/Identifiers.ml +++ /dev/null @@ -1,139 +0,0 @@ -module C = Collections - -(** Signature for a module describing an identifier. - - We often need identifiers (for definitions, variables, etc.) and in - order to make sure we don't mix them, we use a generative functor - (see {!IdGen}). -*) -module type Id = sig - type id - - (** Id generator - simply a counter *) - type generator - - val zero : id - val generator_zero : generator - val generator_from_incr_id : id -> generator - val fresh_stateful_generator : unit -> generator ref * (unit -> id) - val mk_stateful_generator : generator -> generator ref * (unit -> id) - val incr : id -> id - - (* TODO: this should be stateful! - but we may want to be able to duplicate - contexts... - Maybe we could have a [fresh] and a [global_fresh] - TODO: change the order of the returned types - *) - val fresh : generator -> id * generator - val to_string : id -> string - val pp_id : Format.formatter -> id -> unit - val show_id : id -> string - val id_of_json : Yojson.Basic.t -> (id, string) result - val compare_id : id -> id -> int - val max : id -> id -> id - val min : id -> id -> id - val pp_generator : Format.formatter -> generator -> unit - val show_generator : generator -> string - val to_int : id -> int - val of_int : int -> id - val nth : 'a list -> id -> 'a - (* TODO: change the signature (invert the index and the list *) - - val nth_opt : 'a list -> id -> 'a option - - (** Update the nth element of the list. - - Raises [Invalid_argument] if the identifier is out of range. - *) - val update_nth : 'a list -> id -> 'a -> 'a list - - val mapi : (id -> 'a -> 'b) -> 'a list -> 'b list - - (** Same as {!mapi}, but where the indices start with 1. - - TODO: generalize to [map_from_i] - *) - val mapi_from1 : (id -> 'a -> 'b) -> 'a list -> 'b list - - val iteri : (id -> 'a -> unit) -> 'a list -> unit - - module Ord : C.OrderedType with type t = id - module Set : C.Set with type elt = id - module Map : C.Map with type key = id -end - -(** Generative functor for identifiers. - - See {!Id}. -*) -module IdGen () : Id = struct - (* TODO: use Z.t *) - type id = int [@@deriving show] - type generator = id [@@deriving show] - - let zero = 0 - let generator_zero = 0 - - let incr x = - (* Identifiers should never overflow (because max_int is a really big - * value - but we really want to make sure we detect overflows if - * they happen *) - if x = max_int then raise (Errors.IntegerOverflow ()) else x + 1 - - let generator_from_incr_id id = incr id - - let mk_stateful_generator g = - let g = ref g in - let fresh () = - let id = !g in - g := incr id; - id - in - (g, fresh) - - let fresh_stateful_generator () = mk_stateful_generator 0 - let fresh gen = (gen, incr gen) - let to_string = string_of_int - let to_int x = x - let of_int x = x - - let id_of_json js = - (* TODO: check boundaries ? *) - match js with - | `Int i -> Ok i - | _ -> Error ("id_of_json: failed on " ^ Yojson.Basic.show js) - - let compare_id = compare - let max id0 id1 = if id0 > id1 then id0 else id1 - let min id0 id1 = if id0 < id1 then id0 else id1 - let nth v id = List.nth v id - let nth_opt v id = List.nth_opt v id - - let rec update_nth vec id v = - match (vec, id) with - | [], _ -> raise (Invalid_argument "Out of range") - | _ :: vec', 0 -> v :: vec' - | x :: vec', _ -> x :: update_nth vec' (id - 1) v - - let mapi = List.mapi - - let mapi_from1 f ls = - let rec aux i ls = - match ls with [] -> [] | x :: ls' -> f i x :: aux (i + 1) ls' - in - aux 1 ls - - let iteri = List.iteri - - module Ord = struct - type t = id - - let compare = compare - let to_string = to_string - let pp_t = pp_id - let show_t = show_id - end - - module Set = C.MakeSet (Ord) - module Map = C.MakeMap (Ord) -end diff --git a/src/Interpreter.ml b/src/Interpreter.ml deleted file mode 100644 index 7f51c5b9..00000000 --- a/src/Interpreter.ml +++ /dev/null @@ -1,396 +0,0 @@ -open Cps -open InterpreterUtils -open InterpreterProjectors -open InterpreterBorrows -open InterpreterStatements -open LlbcAstUtils -module L = Logging -module T = Types -module A = LlbcAst -module SA = SymbolicAst - -(** The local logger *) -let log = L.interpreter_log - -let compute_type_fun_global_contexts (m : Crates.llbc_crate) : - C.type_context * C.fun_context * C.global_context = - let type_decls_list, _, _ = Crates.split_declarations m.declarations in - let type_decls, fun_decls, global_decls = Crates.compute_defs_maps m in - let type_decls_groups, _funs_defs_groups, _globals_defs_groups = - Crates.split_declarations_to_group_maps m.declarations - in - let type_infos = - TypesAnalysis.analyze_type_declarations type_decls type_decls_list - in - let type_context = { C.type_decls_groups; type_decls; type_infos } in - let fun_context = { C.fun_decls } in - let global_context = { C.global_decls } in - (type_context, fun_context, global_context) - -let initialize_eval_context (type_context : C.type_context) - (fun_context : C.fun_context) (global_context : C.global_context) - (type_vars : T.type_var list) : C.eval_ctx = - C.reset_global_counters (); - { - C.type_context; - C.fun_context; - C.global_context; - C.type_vars; - C.env = [ C.Frame ]; - C.ended_regions = T.RegionId.Set.empty; - } - -(** Initialize an evaluation context to execute a function. - - Introduces local variables initialized in the following manner: - - input arguments are initialized as symbolic values - - the remaining locals are initialized as [⊥] - Abstractions are introduced for the regions present in the function - signature. - - We return: - - the initialized evaluation context - - the list of symbolic values introduced for the input values - - the instantiated function signature - *) -let initialize_symbolic_context_for_fun (type_context : C.type_context) - (fun_context : C.fun_context) (global_context : C.global_context) - (fdef : A.fun_decl) : C.eval_ctx * V.symbolic_value list * A.inst_fun_sig = - (* The abstractions are not initialized the same way as for function - * calls: they contain *loan* projectors, because they "provide" us - * with the input values (which behave as if they had been returned - * by some function calls...). - * Also, note that we properly set the set of parents of every abstraction: - * this should not be necessary, as those abstractions should never be - * *automatically* ended (because ending some borrows requires to end - * one of them), but rather selectively ended when generating code - * for each of the backward functions. We do it only because we can - * do it, and because it gives a bit of sanity. - * *) - let sg = fdef.signature in - (* Create the context *) - let ctx = - initialize_eval_context type_context fun_context global_context - sg.type_params - in - (* Instantiate the signature *) - let type_params = List.map (fun tv -> T.TypeVar tv.T.index) sg.type_params in - let inst_sg = instantiate_fun_sig type_params sg in - (* Create fresh symbolic values for the inputs *) - let input_svs = - List.map (fun ty -> mk_fresh_symbolic_value V.SynthInput ty) inst_sg.inputs - in - (* Initialize the abstractions as empty (i.e., with no avalues) abstractions *) - let call_id = C.fresh_fun_call_id () in - assert (call_id = V.FunCallId.zero); - let compute_abs_avalues (abs : V.abs) (ctx : C.eval_ctx) : - C.eval_ctx * V.typed_avalue list = - (* Project over the values - we use *loan* projectors, as explained above *) - let avalues = - List.map (mk_aproj_loans_value_from_symbolic_value abs.regions) input_svs - in - (ctx, avalues) - in - let region_can_end _ = true in - let ctx = - create_push_abstractions_from_abs_region_groups call_id V.SynthInput - inst_sg.A.regions_hierarchy region_can_end compute_abs_avalues ctx - in - (* Split the variables between return var, inputs and remaining locals *) - let body = Option.get fdef.body in - let ret_var = List.hd body.locals in - let input_vars, local_vars = - Collections.List.split_at (List.tl body.locals) body.arg_count - in - (* Push the return variable (initialized with ⊥) *) - let ctx = C.ctx_push_uninitialized_var ctx ret_var in - (* Push the input variables (initialized with symbolic values) *) - let input_values = List.map mk_typed_value_from_symbolic_value input_svs in - let ctx = C.ctx_push_vars ctx (List.combine input_vars input_values) in - (* Push the remaining local variables (initialized with ⊥) *) - let ctx = C.ctx_push_uninitialized_vars ctx local_vars in - (* Return *) - (ctx, input_svs, inst_sg) - -(** Small helper. - - This is a continuation function called by the symbolic interpreter upon - reaching the [return] instruction when synthesizing a *backward* function: - this continuation takes care of doing the proper manipulations to finish - the synthesis (mostly by ending abstractions). -*) -let evaluate_function_symbolic_synthesize_backward_from_return - (config : C.config) (fdef : A.fun_decl) (inst_sg : A.inst_fun_sig) - (back_id : T.RegionGroupId.id) (ctx : C.eval_ctx) : SA.expression option = - (* We need to instantiate the function signature - to retrieve - * the return type. Note that it is important to re-generate - * an instantiation of the signature, so that we use fresh - * region ids for the return abstractions. *) - let sg = fdef.signature in - let type_params = List.map (fun tv -> T.TypeVar tv.T.index) sg.type_params in - let ret_inst_sg = instantiate_fun_sig type_params sg in - let ret_rty = ret_inst_sg.output in - (* Move the return value out of the return variable *) - let cf_pop_frame = ctx_pop_frame config in - - (* We need to find the parents regions/abstractions of the region we - * will end - this will allow us to, first, mark the other return - * regions as non-endable, and, second, end those parent regions in - * proper order. *) - let parent_rgs = list_parent_region_groups sg back_id in - let parent_input_abs_ids = - T.RegionGroupId.mapi - (fun rg_id rg -> - if T.RegionGroupId.Set.mem rg_id parent_rgs then Some rg.T.id else None) - inst_sg.regions_hierarchy - in - let parent_input_abs_ids = - List.filter_map (fun x -> x) parent_input_abs_ids - in - - (* Insert the return value in the return abstractions (by applying - * borrow projections) *) - let cf_consume_ret ret_value ctx = - let ret_call_id = C.fresh_fun_call_id () in - let compute_abs_avalues (abs : V.abs) (ctx : C.eval_ctx) : - C.eval_ctx * V.typed_avalue list = - let ctx, avalue = - apply_proj_borrows_on_input_value config ctx abs.regions - abs.ancestors_regions ret_value ret_rty - in - (ctx, [ avalue ]) - in - - (* Initialize and insert the abstractions in the context. - * - * We take care of disallowing ending the return regions which we - * shouldn't end (see the documentation of the [can_end] field of [abs] - * for more information. *) - let parent_and_current_rgs = T.RegionGroupId.Set.add back_id parent_rgs in - let region_can_end rid = - T.RegionGroupId.Set.mem rid parent_and_current_rgs - in - assert (region_can_end back_id); - let ctx = - create_push_abstractions_from_abs_region_groups ret_call_id V.SynthRet - ret_inst_sg.A.regions_hierarchy region_can_end compute_abs_avalues ctx - in - - (* We now need to end the proper *input* abstractions - pay attention - * to the fact that we end the *input* abstractions, not the *return* - * abstractions (of course, the corresponding return abstractions will - * automatically be ended, because they consumed values coming from the - * input abstractions...) *) - (* End the parent abstractions and the current abstraction - note that we - * end them in an order which follows the regions hierarchy: it should lead - * to generated code which has a better consistency between the parent - * and children backward functions *) - let current_abs_id = - (T.RegionGroupId.nth inst_sg.regions_hierarchy back_id).id - in - let target_abs_ids = List.append parent_input_abs_ids [ current_abs_id ] in - let cf_end_target_abs cf = - List.fold_left - (fun cf id -> end_abstraction config [] id cf) - cf target_abs_ids - in - (* Generate the Return node *) - let cf_return : m_fun = fun _ -> Some (SA.Return None) in - (* Apply *) - cf_end_target_abs cf_return ctx - in - cf_pop_frame cf_consume_ret ctx - -(** Evaluate a function with the symbolic interpreter. - - We return: - - the list of symbolic values introduced for the input values (this is useful - for the synthesis) - - the symbolic AST generated by the symbolic execution - *) -let evaluate_function_symbolic (config : C.partial_config) (synthesize : bool) - (type_context : C.type_context) (fun_context : C.fun_context) - (global_context : C.global_context) (fdef : A.fun_decl) - (back_id : T.RegionGroupId.id option) : - V.symbolic_value list * SA.expression option = - (* Debug *) - let name_to_string () = - Print.fun_name_to_string fdef.A.name - ^ " (" - ^ Print.option_to_string T.RegionGroupId.to_string back_id - ^ ")" - in - log#ldebug (lazy ("evaluate_function_symbolic: " ^ name_to_string ())); - - (* Create the evaluation context *) - let ctx, input_svs, inst_sg = - initialize_symbolic_context_for_fun type_context fun_context global_context - fdef - in - - (* Create the continuation to finish the evaluation *) - let config = C.config_of_partial C.SymbolicMode config in - let cf_finish res ctx = - match res with - | Return -> - if synthesize then - (* There are two cases: - * - if this is a forward translation, we retrieve the returned value. - * - if this is a backward translation, we introduce "return" - * abstractions to consume the return value, then end all the - * abstractions up to the one in which we are interested. - *) - match back_id with - | None -> - (* Forward translation *) - (* Pop the frame and retrieve the returned value at the same time*) - let cf_pop = ctx_pop_frame config in - (* Generate the Return node *) - let cf_return ret_value : m_fun = - fun _ -> Some (SA.Return (Some ret_value)) - in - (* Apply *) - cf_pop cf_return ctx - | Some back_id -> - (* Backward translation *) - evaluate_function_symbolic_synthesize_backward_from_return config - fdef inst_sg back_id ctx - else None - | Panic -> - (* Note that as we explore all the execution branches, one of - * the executions can lead to a panic *) - if synthesize then Some SA.Panic else None - | _ -> - failwith ("evaluate_function_symbolic failed on: " ^ name_to_string ()) - in - - (* Evaluate the function *) - let symbolic = - eval_function_body config (Option.get fdef.A.body).body cf_finish ctx - in - - (* Return *) - (input_svs, symbolic) - -module Test = struct - (** Test a unit function (taking no arguments) by evaluating it in an empty - environment. - *) - let test_unit_function (config : C.partial_config) (crate : Crates.llbc_crate) - (fid : A.FunDeclId.id) : unit = - (* Retrieve the function declaration *) - let fdef = A.FunDeclId.nth crate.functions fid in - let body = Option.get fdef.body in - - (* Debug *) - log#ldebug - (lazy ("test_unit_function: " ^ Print.fun_name_to_string fdef.A.name)); - - (* Sanity check - *) - assert (List.length fdef.A.signature.region_params = 0); - assert (List.length fdef.A.signature.type_params = 0); - assert (body.A.arg_count = 0); - - (* Create the evaluation context *) - let type_context, fun_context, global_context = - compute_type_fun_global_contexts crate - in - let ctx = - initialize_eval_context type_context fun_context global_context [] - in - - (* Insert the (uninitialized) local variables *) - let ctx = C.ctx_push_uninitialized_vars ctx body.A.locals in - - (* Create the continuation to check the function's result *) - let config = C.config_of_partial C.ConcreteMode config in - let cf_check res ctx = - match res with - | Return -> - (* Ok: drop the local variables and finish *) - ctx_pop_frame config (fun _ _ -> None) ctx - | _ -> - failwith - ("Unit test failed (concrete execution) on: " - ^ Print.fun_name_to_string fdef.A.name) - in - - (* Evaluate the function *) - let _ = eval_function_body config body.body cf_check ctx in - () - - (** Small helper: return true if the function is a *transparent* unit function - (no parameters, no arguments) - TODO: move *) - let fun_decl_is_transparent_unit (def : A.fun_decl) : bool = - match def.body with - | None -> false - | Some body -> - body.arg_count = 0 - && List.length def.A.signature.region_params = 0 - && List.length def.A.signature.type_params = 0 - && List.length def.A.signature.inputs = 0 - - (** Test all the unit functions in a list of function definitions *) - let test_unit_functions (config : C.partial_config) - (crate : Crates.llbc_crate) : unit = - let unit_funs = List.filter fun_decl_is_transparent_unit crate.functions in - let test_unit_fun (def : A.fun_decl) : unit = - test_unit_function config crate def.A.def_id - in - List.iter test_unit_fun unit_funs - - (** Execute the symbolic interpreter on a function. *) - let test_function_symbolic (config : C.partial_config) (synthesize : bool) - (type_context : C.type_context) (fun_context : C.fun_context) - (global_context : C.global_context) (fdef : A.fun_decl) : unit = - (* Debug *) - log#ldebug - (lazy ("test_function_symbolic: " ^ Print.fun_name_to_string fdef.A.name)); - - (* Evaluate *) - let evaluate = - evaluate_function_symbolic config synthesize type_context fun_context - global_context fdef - in - (* Execute the forward function *) - let _ = evaluate None in - (* Execute the backward functions *) - let _ = - T.RegionGroupId.mapi - (fun gid _ -> evaluate (Some gid)) - fdef.signature.regions_hierarchy - in - - () - - (** Small helper *) - let fun_decl_is_transparent (def : A.fun_decl) : bool = - Option.is_some def.body - - (** Execute the symbolic interpreter on a list of functions. - - TODO: for now we ignore the functions which contain loops, because - they are not supported by the symbolic interpreter. - *) - let test_functions_symbolic (config : C.partial_config) (synthesize : bool) - (crate : Crates.llbc_crate) : unit = - (* Filter the functions which contain loops *) - let no_loop_funs = - List.filter - (fun f -> not (LlbcAstUtils.fun_decl_has_loops f)) - crate.functions - in - (* Filter the opaque functions *) - let no_loop_funs = List.filter fun_decl_is_transparent no_loop_funs in - let type_context, fun_context, global_context = - compute_type_fun_global_contexts crate - in - let test_fun (def : A.fun_decl) : unit = - (* Execute the function - note that as the symbolic interpreter explores - * all the path, some executions are expected to "panic": we thus don't - * check the return value *) - test_function_symbolic config synthesize type_context fun_context - global_context def - in - List.iter test_fun no_loop_funs -end diff --git a/src/InterpreterBorrows.ml b/src/InterpreterBorrows.ml deleted file mode 100644 index 30c3b221..00000000 --- a/src/InterpreterBorrows.ml +++ /dev/null @@ -1,1580 +0,0 @@ -module T = Types -module V = Values -module C = Contexts -module Subst = Substitute -module L = Logging -module S = SynthesizeSymbolic -open Cps -open ValuesUtils -open TypesUtils -open InterpreterUtils -open InterpreterBorrowsCore -open InterpreterProjectors - -(** The local logger *) -let log = InterpreterBorrowsCore.log - -(** Auxiliary function to end borrows: lookup a borrow in the environment, - update it (by returning an updated environment where the borrow has been - replaced by {!V.Bottom})) if we can end the borrow (for instance, it is not - an outer borrow...) or return the reason why we couldn't update the borrow. - - [end_borrow] then simply performs a loop: as long as we need to end (outer) - borrows, we end them, before finally ending the borrow we wanted to end in the - first place. - - Note that it is possible to end a borrow in an abstraction, without ending - the whole abstraction, if the corresponding loan is inside the abstraction - as well. The [allowed_abs] parameter controls whether we allow to end borrows - in an abstraction or not, and in which abstraction. -*) -let end_borrow_get_borrow (allowed_abs : V.AbstractionId.id option) - (l : V.BorrowId.id) (ctx : C.eval_ctx) : - (C.eval_ctx * g_borrow_content option, priority_borrows_or_abs) result = - (* We use a reference to communicate the kind of borrow we found, if we - * find one *) - let replaced_bc : g_borrow_content option ref = ref None in - let set_replaced_bc (bc : g_borrow_content) = - assert (Option.is_none !replaced_bc); - replaced_bc := Some bc - in - (* Raise an exception if: - * - there are outer borrows - * - if we are inside an abstraction - * - there are inner loans - * this exception is caught in a wrapper function *) - let raise_if_priority (outer : V.AbstractionId.id option * borrow_ids option) - (borrowed_value : V.typed_value option) = - (* First, look for outer borrows or abstraction *) - let outer_abs, outer_borrows = outer in - (match outer_abs with - | Some abs -> ( - if - (* Check if we can end borrows inside this abstraction *) - Some abs <> allowed_abs - then raise (FoundPriority (OuterAbs abs)) - else - match outer_borrows with - | Some borrows -> raise (FoundPriority (OuterBorrows borrows)) - | None -> ()) - | None -> ( - match outer_borrows with - | Some borrows -> raise (FoundPriority (OuterBorrows borrows)) - | None -> ())); - (* Then check if there are inner loans *) - match borrowed_value with - | None -> () - | Some v -> ( - match get_first_loan_in_value v with - | None -> () - | Some c -> ( - match c with - | V.SharedLoan (bids, _) -> - raise (FoundPriority (InnerLoans (Borrows bids))) - | V.MutLoan bid -> raise (FoundPriority (InnerLoans (Borrow bid))))) - in - - (* The environment is used to keep track of the outer loans *) - let obj = - object - inherit [_] C.map_eval_ctx as super - - (** We reimplement {!visit_Loan} because we may have to update the - outer borrows *) - method! visit_Loan (outer : V.AbstractionId.id option * borrow_ids option) - lc = - match lc with - | V.MutLoan bid -> V.Loan (super#visit_MutLoan outer bid) - | V.SharedLoan (bids, v) -> - (* Update the outer borrows before diving into the shared value *) - let outer = update_outer_borrows outer (Borrows bids) in - V.Loan (super#visit_SharedLoan outer bids v) - - method! visit_Borrow outer bc = - match bc with - | SharedBorrow (_, l') | InactivatedMutBorrow (_, l') -> - (* Check if this is the borrow we are looking for *) - if l = l' then ( - (* Check if there are outer borrows or if we are inside an abstraction *) - raise_if_priority outer None; - (* Register the update *) - set_replaced_bc (Concrete bc); - (* Update the value *) - V.Bottom) - else super#visit_Borrow outer bc - | V.MutBorrow (l', bv) -> - (* Check if this is the borrow we are looking for *) - if l = l' then ( - (* Check if there are outer borrows or if we are inside an abstraction *) - raise_if_priority outer (Some bv); - (* Register the update *) - set_replaced_bc (Concrete bc); - (* Update the value *) - V.Bottom) - else - (* Update the outer borrows before diving into the borrowed value *) - let outer = update_outer_borrows outer (Borrow l') in - V.Borrow (super#visit_MutBorrow outer l' bv) - - (** We reimplement {!visit_ALoan} because we may have to update the - outer borrows *) - method! visit_ALoan outer lc = - (* Note that the children avalues are just other, independent loans, - * so we don't need to update the outer borrows when diving in. - * We keep track of the parents/children relationship only because we - * need it to properly instantiate the backward functions when generating - * the pure translation. *) - match lc with - | V.AMutLoan (_, _) -> - (* Nothing special to do *) - super#visit_ALoan outer lc - | V.ASharedLoan (bids, v, av) -> - (* Explore the shared value - we need to update the outer borrows *) - let souter = update_outer_borrows outer (Borrows bids) in - let v = super#visit_typed_value souter v in - (* Explore the child avalue - we keep the same outer borrows *) - let av = super#visit_typed_avalue outer av in - (* Reconstruct *) - V.ALoan (V.ASharedLoan (bids, v, av)) - | V.AEndedMutLoan { given_back = _; child = _; given_back_meta = _ } - | V.AEndedSharedLoan _ - (* The loan has ended, so no need to update the outer borrows *) - | V.AIgnoredMutLoan _ (* Nothing special to do *) - | V.AEndedIgnoredMutLoan - { given_back = _; child = _; given_back_meta = _ } - (* Nothing special to do *) - | V.AIgnoredSharedLoan _ -> - (* Nothing special to do *) - super#visit_ALoan outer lc - - method! visit_ABorrow outer bc = - match bc with - | V.AMutBorrow (_, bid, _) -> - (* Check if this is the borrow we are looking for *) - if bid = l then ( - (* When ending a mut borrow, there are two cases: - * - in the general case, we have to end the whole abstraction - * (and thus raise an exception to signal that to the caller) - * - in some situations, the associated loan is inside the same - * abstraction as the borrow. In this situation, we can end - * the borrow without ending the whole abstraction, and we - * simply move the child avalue around. - *) - (* Check there are outer borrows, or if we need to end the whole - * abstraction *) - raise_if_priority outer None; - (* Register the update *) - set_replaced_bc (Abstract bc); - (* Update the value - note that we are necessarily in the second - * of the two cases described above. - * Also note that, as we are moving the borrowed value inside the - * abstraction (and not really giving the value back to the context) - * we do not insert {!AEndedMutBorrow} but rather {!ABottom} *) - V.ABottom) - else - (* Update the outer borrows before diving into the child avalue *) - let outer = update_outer_borrows outer (Borrow bid) in - super#visit_ABorrow outer bc - | V.ASharedBorrow bid -> - (* Check if this is the borrow we are looking for *) - if bid = l then ( - (* Check there are outer borrows, or if we need to end the whole - * abstraction *) - raise_if_priority outer None; - (* Register the update *) - set_replaced_bc (Abstract bc); - (* Update the value - note that we are necessarily in the second - * of the two cases described above *) - V.ABottom) - else super#visit_ABorrow outer bc - | V.AIgnoredMutBorrow (_, _) - | V.AEndedMutBorrow _ - | V.AEndedIgnoredMutBorrow - { given_back_loans_proj = _; child = _; given_back_meta = _ } - | V.AEndedSharedBorrow -> - (* Nothing special to do *) - super#visit_ABorrow outer bc - | V.AProjSharedBorrow asb -> - (* Check if the borrow we are looking for is in the asb *) - if borrow_in_asb l asb then ( - (* Check there are outer borrows, or if we need to end the whole - * abstraction *) - raise_if_priority outer None; - (* Register the update *) - set_replaced_bc (Abstract bc); - (* Update the value - note that we are necessarily in the second - * of the two cases described above *) - let asb = remove_borrow_from_asb l asb in - V.ABorrow (V.AProjSharedBorrow asb)) - else (* Nothing special to do *) - super#visit_ABorrow outer bc - - method! visit_abs outer abs = - (* Update the outer abs *) - let outer_abs, outer_borrows = outer in - assert (Option.is_none outer_abs); - assert (Option.is_none outer_borrows); - let outer = (Some abs.V.abs_id, None) in - super#visit_abs outer abs - end - in - (* Catch the exceptions - raised if there are outer borrows *) - try - let ctx = obj#visit_eval_ctx (None, None) ctx in - Ok (ctx, !replaced_bc) - with FoundPriority outers -> Error outers - -(** Auxiliary function to end borrows. See [give_back]. - - When we end a mutable borrow, we need to "give back" the value it contained - to its original owner by reinserting it at the proper position. - - Note that this function checks that there is exactly one loan to which we - give the value back. - TODO: this was not the case before, so some sanity checks are not useful anymore. - *) -let give_back_value (config : C.config) (bid : V.BorrowId.id) - (nv : V.typed_value) (ctx : C.eval_ctx) : C.eval_ctx = - (* Sanity check *) - assert (not (loans_in_value nv)); - assert (not (bottom_in_value ctx.ended_regions nv)); - (* Debug *) - log#ldebug - (lazy - ("give_back_value:\n- bid: " ^ V.BorrowId.to_string bid ^ "\n- value: " - ^ typed_value_to_string ctx nv - ^ "\n- context:\n" ^ eval_ctx_to_string ctx ^ "\n")); - (* We use a reference to check that we updated exactly one loan *) - let replaced : bool ref = ref false in - let set_replaced () = - assert (not !replaced); - replaced := true - in - (* Whenever giving back symbolic values, they shouldn't contain already ended regions *) - let check_symbolic_no_ended = true in - (* We sometimes need to reborrow values while giving a value back due: prepare that *) - let allow_reborrows = true in - let fresh_reborrow, apply_registered_reborrows = - prepare_reborrows config allow_reborrows - in - (* The visitor to give back the values *) - let obj = - object (self) - inherit [_] C.map_eval_ctx as super - - (** This is a bit annoying, but as we need the type of the value we - are exploring, for sanity checks, we need to implement - {!visit_typed_avalue} instead of - overriding {!visit_ALoan} *) - method! visit_typed_value opt_abs (v : V.typed_value) : V.typed_value = - match v.V.value with - | V.Loan lc -> - let value = self#visit_typed_Loan opt_abs v.V.ty lc in - ({ v with V.value } : V.typed_value) - | _ -> super#visit_typed_value opt_abs v - - method visit_typed_Loan opt_abs ty lc = - match lc with - | V.SharedLoan (bids, v) -> - (* We are giving back a value (i.e., the content of a *mutable* - * borrow): nothing special to do *) - V.Loan (super#visit_SharedLoan opt_abs bids v) - | V.MutLoan bid' -> - (* Check if this is the loan we are looking for *) - if bid' = bid then ( - (* Sanity check *) - let expected_ty = ty in - if nv.V.ty <> expected_ty then ( - log#serror - ("give_back_value: improper type:\n- expected: " - ^ ety_to_string ctx ty ^ "\n- received: " - ^ ety_to_string ctx nv.V.ty); - failwith "Value given back doesn't have the proper type"); - (* Replace *) - set_replaced (); - nv.V.value) - else V.Loan (super#visit_MutLoan opt_abs bid') - - (** This is a bit annoying, but as we need the type of the avalue we - are exploring, in order to be able to project the value we give - back, we need to reimplement {!visit_typed_avalue} instead of - {!visit_ALoan} *) - method! visit_typed_avalue opt_abs (av : V.typed_avalue) : V.typed_avalue - = - match av.V.value with - | V.ALoan lc -> - let value = self#visit_typed_ALoan opt_abs av.V.ty lc in - ({ av with V.value } : V.typed_avalue) - | _ -> super#visit_typed_avalue opt_abs av - - (** We need to inspect ignored mutable borrows, to insert loan projectors - if necessary. - *) - method! visit_ABorrow (opt_abs : V.abs option) (bc : V.aborrow_content) - : V.avalue = - match bc with - | V.AIgnoredMutBorrow (bid', child) -> - if bid' = Some bid then - (* Insert a loans projector - note that if this case happens, - * it is necessarily because we ended a parent abstraction, - * and the given back value is thus a symbolic value *) - match nv.V.value with - | V.Symbolic sv -> - let abs = Option.get opt_abs in - (* Remember the given back value as a meta-value - * TODO: it is a bit annoying to have to deconstruct - * the value... Think about a more elegant way. *) - let given_back_meta = as_symbolic nv.value in - (* The loan projector *) - let given_back_loans_proj = - mk_aproj_loans_value_from_symbolic_value abs.regions sv - in - (* Continue giving back in the child value *) - let child = super#visit_typed_avalue opt_abs child in - (* Return *) - V.ABorrow - (V.AEndedIgnoredMutBorrow - { given_back_loans_proj; child; given_back_meta }) - | _ -> failwith "Unreachable" - else - (* Continue exploring *) - V.ABorrow (super#visit_AIgnoredMutBorrow opt_abs bid' child) - | _ -> - (* Continue exploring *) - super#visit_ABorrow opt_abs bc - - (** We are not specializing an already existing method, but adding a - new method (for projections, we need type information) *) - method visit_typed_ALoan (opt_abs : V.abs option) (ty : T.rty) - (lc : V.aloan_content) : V.avalue = - (* Preparing a bit *) - let regions, ancestors_regions = - match opt_abs with - | None -> failwith "Unreachable" - | Some abs -> (abs.V.regions, abs.V.ancestors_regions) - in - (* Rk.: there is a small issue with the types of the aloan values. - * See the comment at the level of definition of {!typed_avalue} *) - let borrowed_value_aty = - let _, ty, _ = ty_get_ref ty in - ty - in - match lc with - | V.AMutLoan (bid', child) -> - if bid' = bid then ( - (* This is the loan we are looking for: apply the projection to - * the value we give back and replaced this mutable loan with - * an ended loan *) - (* Register the insertion *) - set_replaced (); - (* Remember the given back value as a meta-value *) - let given_back_meta = nv in - (* Apply the projection *) - let given_back = - apply_proj_borrows check_symbolic_no_ended ctx fresh_reborrow - regions ancestors_regions nv borrowed_value_aty - in - (* Continue giving back in the child value *) - let child = super#visit_typed_avalue opt_abs child in - (* Return the new value *) - V.ALoan (V.AEndedMutLoan { child; given_back; given_back_meta })) - else (* Continue exploring *) - super#visit_ALoan opt_abs lc - | V.ASharedLoan (_, _, _) -> - (* We are giving back a value to a *mutable* loan: nothing special to do *) - super#visit_ALoan opt_abs lc - | V.AEndedMutLoan { child = _; given_back = _; given_back_meta = _ } - | V.AEndedSharedLoan (_, _) -> - (* Nothing special to do *) - super#visit_ALoan opt_abs lc - | V.AIgnoredMutLoan (bid', child) -> - (* This loan is ignored, but we may have to project on a subvalue - * of the value which is given back *) - if bid' = bid then - (* Remember the given back value as a meta-value *) - let given_back_meta = nv in - (* Note that we replace the ignored mut loan by an *ended* ignored - * mut loan. Also, this is not the loan we are looking for *per se*: - * we don't register the fact that we inserted the value somewhere - * (i.e., we don't call {!set_replaced}) *) - let given_back = - apply_proj_borrows check_symbolic_no_ended ctx fresh_reborrow - regions ancestors_regions nv borrowed_value_aty - in - (* Continue giving back in the child value *) - let child = super#visit_typed_avalue opt_abs child in - V.ALoan - (V.AEndedIgnoredMutLoan { given_back; child; given_back_meta }) - else super#visit_ALoan opt_abs lc - | V.AEndedIgnoredMutLoan - { given_back = _; child = _; given_back_meta = _ } - | V.AIgnoredSharedLoan _ -> - (* Nothing special to do *) - super#visit_ALoan opt_abs lc - - method! visit_Abs opt_abs abs = - (* We remember in which abstraction we are before diving - - * this is necessary for projecting values: we need to know - * over which regions to project *) - assert (Option.is_none opt_abs); - super#visit_Abs (Some abs) abs - end - in - - (* Explore the environment *) - let ctx = obj#visit_eval_ctx None ctx in - (* Check we gave back to exactly one loan *) - assert !replaced; - (* Apply the reborrows *) - apply_registered_reborrows ctx - -(** Give back a *modified* symbolic value. *) -let give_back_symbolic_value (_config : C.config) - (proj_regions : T.RegionId.Set.t) (proj_ty : T.rty) (sv : V.symbolic_value) - (nsv : V.symbolic_value) (ctx : C.eval_ctx) : C.eval_ctx = - (* Sanity checks *) - assert (sv.sv_id <> nsv.sv_id); - (match nsv.sv_kind with - | V.SynthInputGivenBack | V.SynthRetGivenBack | V.FunCallGivenBack -> () - | V.FunCallRet | V.SynthInput | V.Global -> failwith "Unrechable"); - (* Store the given-back value as a meta-value for synthesis purposes *) - let mv = nsv in - (* Substitution function, to replace the borrow projectors over symbolic values *) - let subst (_abs : V.abs) local_given_back = - (* See the below comments: there is something wrong here *) - let _ = raise Errors.Unimplemented in - (* Compute the projection over the given back value *) - let child_proj = - match nsv.sv_kind with - | V.SynthRetGivenBack -> - (* The given back value comes from the return value of the function - we are currently synthesizing (as it is given back, it means - we ended one of the regions appearing in the signature: we are - currently synthesizing one of the backward functions). - - As we don't allow borrow overwrites on returned value, we can - (and MUST) forget the borrows *) - V.AIgnoredProjBorrows - | V.FunCallGivenBack -> - (* TODO: there is something wrong here. - Consider this: - {[ - abs0 {'a} { AProjLoans (s0 : &'a mut T) [] } - abs1 {'b} { AProjBorrows (s0 : &'a mut T <: &'b mut T) } - ]} - - Upon ending abs1, we give back some fresh symbolic value [s1], - that we reinsert where the loan for [s0] is. However, the mutable - borrow in the type [&'a mut T] was ended: we give back a value of - type [T]! We thus *mustn't* introduce a projector here. - *) - V.AProjBorrows (nsv, sv.V.sv_ty) - | _ -> failwith "Unreachable" - in - V.AProjLoans (sv, (mv, child_proj) :: local_given_back) - in - update_intersecting_aproj_loans proj_regions proj_ty sv subst ctx - -(** Auxiliary function to end borrows. See [give_back]. - - This function is similar to {!give_back_value} but gives back an {!V.avalue} - (coming from an abstraction). - - It is used when ending a borrow inside an abstraction, when the corresponding - loan is inside the same abstraction (in which case we don't need to end the whole - abstraction). - - REMARK: this function can't be used to give back the values borrowed by - end abstraction when ending this abstraction. When doing this, we need - to convert the {!V.avalue} to a {!type:V.value} by introducing the proper symbolic values. - *) -let give_back_avalue_to_same_abstraction (_config : C.config) - (bid : V.BorrowId.id) (mv : V.mvalue) (nv : V.typed_avalue) - (ctx : C.eval_ctx) : C.eval_ctx = - (* We use a reference to check that we updated exactly one loan *) - let replaced : bool ref = ref false in - let set_replaced () = - assert (not !replaced); - replaced := true - in - let obj = - object (self) - inherit [_] C.map_eval_ctx as super - - (** This is a bit annoying, but as we need the type of the avalue we - are exploring, in order to be able to project the value we give - back, we need to reimplement {!visit_typed_avalue} instead of - {!visit_ALoan} *) - method! visit_typed_avalue opt_abs (av : V.typed_avalue) : V.typed_avalue - = - match av.V.value with - | V.ALoan lc -> - let value = self#visit_typed_ALoan opt_abs av.V.ty lc in - ({ av with V.value } : V.typed_avalue) - | _ -> super#visit_typed_avalue opt_abs av - - (** We are not specializing an already existing method, but adding a - new method (for projections, we need type information) *) - method visit_typed_ALoan (opt_abs : V.abs option) (ty : T.rty) - (lc : V.aloan_content) : V.avalue = - match lc with - | V.AMutLoan (bid', child) -> - if bid' = bid then ( - (* Sanity check - about why we need to call {!ty_get_ref} - * (and don't do the same thing as in {!give_back_value}) - * see the comment at the level of the definition of - * {!typed_avalue} *) - let _, expected_ty, _ = ty_get_ref ty in - if nv.V.ty <> expected_ty then ( - log#serror - ("give_back_avalue_to_same_abstraction: improper type:\n\ - - expected: " ^ rty_to_string ctx ty ^ "\n- received: " - ^ rty_to_string ctx nv.V.ty); - failwith "Value given back doesn't have the proper type"); - (* This is the loan we are looking for: apply the projection to - * the value we give back and replaced this mutable loan with - * an ended loan *) - (* Register the insertion *) - set_replaced (); - (* Return the new value *) - V.ALoan - (V.AEndedMutLoan - { given_back = nv; child; given_back_meta = mv })) - else (* Continue exploring *) - super#visit_ALoan opt_abs lc - | V.ASharedLoan (_, _, _) - (* We are giving back a value to a *mutable* loan: nothing special to do *) - | V.AEndedMutLoan { given_back = _; child = _; given_back_meta = _ } - | V.AEndedSharedLoan (_, _) -> - (* Nothing special to do *) - super#visit_ALoan opt_abs lc - | V.AIgnoredMutLoan (bid', child) -> - (* This loan is ignored, but we may have to project on a subvalue - * of the value which is given back *) - if bid' = bid then ( - (* Note that we replace the ignored mut loan by an *ended* ignored - * mut loan. Also, this is not the loan we are looking for *per se*: - * we don't register the fact that we inserted the value somewhere - * (i.e., we don't call {!set_replaced}) *) - (* Sanity check *) - assert (nv.V.ty = ty); - V.ALoan - (V.AEndedIgnoredMutLoan - { given_back = nv; child; given_back_meta = mv })) - else super#visit_ALoan opt_abs lc - | V.AEndedIgnoredMutLoan - { given_back = _; child = _; given_back_meta = _ } - | V.AIgnoredSharedLoan _ -> - (* Nothing special to do *) - super#visit_ALoan opt_abs lc - end - in - - (* Explore the environment *) - let ctx = obj#visit_eval_ctx None ctx in - (* Check we gave back to exactly one loan *) - assert !replaced; - (* Return *) - ctx - -(** Auxiliary function to end borrows. See [give_back]. - - When we end a shared borrow, we need to remove the borrow id from the list - of borrows to the shared value. - - Note that this function checks that there is exactly one shared loan that - we update. - TODO: this was not the case before, so some sanity checks are not useful anymore. - *) -let give_back_shared _config (bid : V.BorrowId.id) (ctx : C.eval_ctx) : - C.eval_ctx = - (* We use a reference to check that we updated exactly one loan *) - let replaced : bool ref = ref false in - let set_replaced () = - assert (not !replaced); - replaced := true - in - let obj = - object - inherit [_] C.map_eval_ctx as super - - method! visit_Loan opt_abs lc = - match lc with - | V.SharedLoan (bids, shared_value) -> - if V.BorrowId.Set.mem bid bids then ( - (* This is the loan we are looking for *) - set_replaced (); - (* If there remains exactly one borrow identifier, we need - * to end the loan. Otherwise, we just remove the current - * loan identifier *) - if V.BorrowId.Set.cardinal bids = 1 then shared_value.V.value - else - V.Loan - (V.SharedLoan (V.BorrowId.Set.remove bid bids, shared_value))) - else - (* Not the loan we are looking for: continue exploring *) - V.Loan (super#visit_SharedLoan opt_abs bids shared_value) - | V.MutLoan bid' -> - (* We are giving back a *shared* borrow: nothing special to do *) - V.Loan (super#visit_MutLoan opt_abs bid') - - method! visit_ALoan opt_abs lc = - match lc with - | V.AMutLoan (bid, av) -> - (* Nothing special to do (we are giving back a *shared* borrow) *) - V.ALoan (super#visit_AMutLoan opt_abs bid av) - | V.ASharedLoan (bids, shared_value, child) -> - if V.BorrowId.Set.mem bid bids then ( - (* This is the loan we are looking for *) - set_replaced (); - (* If there remains exactly one borrow identifier, we need - * to end the loan. Otherwise, we just remove the current - * loan identifier *) - if V.BorrowId.Set.cardinal bids = 1 then - V.ALoan (V.AEndedSharedLoan (shared_value, child)) - else - V.ALoan - (V.ASharedLoan - (V.BorrowId.Set.remove bid bids, shared_value, child))) - else - (* Not the loan we are looking for: continue exploring *) - super#visit_ALoan opt_abs lc - | V.AEndedMutLoan { given_back = _; child = _; given_back_meta = _ } - (* Nothing special to do (the loan has ended) *) - | V.AEndedSharedLoan (_, _) - (* Nothing special to do (the loan has ended) *) - | V.AIgnoredMutLoan (_, _) - (* Nothing special to do (we are giving back a *shared* borrow) *) - | V.AEndedIgnoredMutLoan - { given_back = _; child = _; given_back_meta = _ } - (* Nothing special to do *) - | V.AIgnoredSharedLoan _ -> - (* Nothing special to do *) - super#visit_ALoan opt_abs lc - end - in - - (* Explore the environment *) - let ctx = obj#visit_eval_ctx None ctx in - (* Check we gave back to exactly one loan *) - assert !replaced; - (* Return *) - ctx - -(** When copying values, we duplicate the shared borrows. This is tantamount - to reborrowing the shared value. The following function applies this change - to an environment by inserting a new borrow id in the set of borrows tracked - by a shared value, referenced by the [original_bid] argument. - *) -let reborrow_shared (original_bid : V.BorrowId.id) (new_bid : V.BorrowId.id) - (ctx : C.eval_ctx) : C.eval_ctx = - (* Keep track of changes *) - let r = ref false in - let set_ref () = - assert (not !r); - r := true - in - - let obj = - object - inherit [_] C.map_env as super - - method! visit_SharedLoan env bids sv = - (* Shared loan: check if the borrow id we are looking for is in the - set of borrow ids. If yes, insert the new borrow id, otherwise - explore inside the shared value *) - if V.BorrowId.Set.mem original_bid bids then ( - set_ref (); - let bids' = V.BorrowId.Set.add new_bid bids in - V.SharedLoan (bids', sv)) - else super#visit_SharedLoan env bids sv - - method! visit_ASharedLoan env bids v av = - (* This case is similar to the {!SharedLoan} case *) - if V.BorrowId.Set.mem original_bid bids then ( - set_ref (); - let bids' = V.BorrowId.Set.add new_bid bids in - V.ASharedLoan (bids', v, av)) - else super#visit_ASharedLoan env bids v av - end - in - - let env = obj#visit_env () ctx.env in - (* Check that we reborrowed once *) - assert !r; - { ctx with env } - -(** Auxiliary function: see [end_borrow] *) -let give_back (config : C.config) (l : V.BorrowId.id) (bc : g_borrow_content) - (ctx : C.eval_ctx) : C.eval_ctx = - (* Debug *) - log#ldebug - (lazy - (let bc = - match bc with - | Concrete bc -> borrow_content_to_string ctx bc - | Abstract bc -> aborrow_content_to_string ctx bc - in - "give_back:\n- bid: " ^ V.BorrowId.to_string l ^ "\n- content: " ^ bc - ^ "\n- context:\n" ^ eval_ctx_to_string ctx ^ "\n")); - (* This is used for sanity checks *) - let sanity_ek = - { enter_shared_loans = true; enter_mut_borrows = true; enter_abs = true } - in - match bc with - | Concrete (V.MutBorrow (l', tv)) -> - (* Sanity check *) - assert (l' = l); - assert (not (loans_in_value tv)); - (* Check that the corresponding loan is somewhere - purely a sanity check *) - assert (Option.is_some (lookup_loan_opt sanity_ek l ctx)); - (* Update the context *) - give_back_value config l tv ctx - | Concrete (V.SharedBorrow (_, l') | V.InactivatedMutBorrow (_, l')) -> - (* Sanity check *) - assert (l' = l); - (* Check that the borrow is somewhere - purely a sanity check *) - assert (Option.is_some (lookup_loan_opt sanity_ek l ctx)); - (* Update the context *) - give_back_shared config l ctx - | Abstract (V.AMutBorrow (mv, l', av)) -> - (* Sanity check *) - assert (l' = l); - (* Check that the corresponding loan is somewhere - purely a sanity check *) - assert (Option.is_some (lookup_loan_opt sanity_ek l ctx)); - (* Update the context *) - give_back_avalue_to_same_abstraction config l mv av ctx - | Abstract (V.ASharedBorrow l') -> - (* Sanity check *) - assert (l' = l); - (* Check that the borrow is somewhere - purely a sanity check *) - assert (Option.is_some (lookup_loan_opt sanity_ek l ctx)); - (* Update the context *) - give_back_shared config l ctx - | Abstract (V.AProjSharedBorrow asb) -> - (* Sanity check *) - assert (borrow_in_asb l asb); - (* Update the context *) - give_back_shared config l ctx - | Abstract - ( V.AEndedMutBorrow _ | V.AIgnoredMutBorrow _ | V.AEndedIgnoredMutBorrow _ - | V.AEndedSharedBorrow ) -> - failwith "Unreachable" - -(** Convert an {!type:V.avalue} to a {!type:V.value}. - - This function is used when ending abstractions: whenever we end a borrow - in an abstraction, we converted the borrowed {!V.avalue} to a fresh symbolic - {!type:V.value}, then give back this {!type:V.value} to the context. - - Note that some regions may have ended in the symbolic value we generate. - For instance, consider the following function signature: - {[ - fn f<'a>(x : &'a mut &'a mut u32); - ]} - When ending the abstraction, the value given back for the outer borrow - should be ⊥. In practice, we will give back a symbolic value which can't - be expanded (because expanding this symbolic value would require expanding - a reference whose region has already ended). - *) -let convert_avalue_to_given_back_value (abs_kind : V.abs_kind) - (av : V.typed_avalue) : V.symbolic_value = - let sv_kind = - match abs_kind with - | V.FunCall -> V.FunCallGivenBack - | V.SynthRet -> V.SynthRetGivenBack - | V.SynthInput -> V.SynthInputGivenBack - in - mk_fresh_symbolic_value sv_kind av.V.ty - -(** End a borrow identified by its borrow id in a context. - - Rk.: from now onwards, the functions are written in continuation passing style. - The reason is that when ending borrows we may end abstractions, which results - in synthesized code. - - First lookup the borrow in the context and replace it with {!V.Bottom}. - Then, check that there is an associated loan in the context. When moving - values, before putting the value in its destination, we get an - intermediate state where some values are "outside" the context and thus - inaccessible. As {!give_back_value} just performs a map for instance (TODO: - not the case anymore), we need to check independently that there is indeed a - loan ready to receive the value we give back (note that we also have other - invariants like: there is exacly one mutable loan associated to a mutable - borrow, etc. but they are more easily maintained). - Note that in theory, we shouldn't never reach a problematic state as the - one we describe above, because when we move a value we need to end all the - loans inside before moving it. Still, it is a very useful sanity check. - Finally, give the values back. - - Of course, we end outer borrows before updating the target borrow if it - proves necessary. - If a borrow is inside an abstraction, we need to end the whole abstraction, - at the exception of the case where the loan corresponding to the borrow is - inside the same abstraction. We control this with the [allowed_abs] parameter: - if it is not [None], we allow ending a borrow if it is inside the given - abstraction. In practice, if the value is [Some abs_id], we should have - checked that the corresponding loan is inside the abstraction given by - [abs_id] before. In practice, only {!end_borrow} should call itself - with [allowed_abs = Some ...], all the other calls should use [allowed_abs = None]: - if you look ath the implementation details, [end_borrow] performs - all tne necessary checks in case a borrow is inside an abstraction. - TODO: we shouldn't allow this last case (end a borrow when the corresponding - loan is in the same abstraction). - - TODO: we should split this function in two: one function which doesn't - perform anything smart and is trusted, and another function for the - book-keeping. - *) -let rec end_borrow (config : C.config) (chain : borrow_or_abs_ids) - (allowed_abs : V.AbstractionId.id option) (l : V.BorrowId.id) : cm_fun = - fun cf ctx -> - (* Check that we don't loop *) - let chain0 = chain in - let chain = add_borrow_or_abs_id_to_chain "end_borrow: " (BorrowId l) chain in - log#ldebug - (lazy - ("end borrow: " ^ V.BorrowId.to_string l ^ ":\n- original context:\n" - ^ eval_ctx_to_string ctx)); - - (* Utility function for the sanity checks: check that the borrow disappeared - * from the context *) - let ctx0 = ctx in - let check_disappeared (ctx : C.eval_ctx) : unit = - let _ = - match lookup_borrow_opt ek_all l ctx with - | None -> () (* Ok *) - | Some _ -> - log#lerror - (lazy - ("end borrow: " ^ V.BorrowId.to_string l - ^ ": borrow didn't disappear:\n- original context:\n" - ^ eval_ctx_to_string ctx0 ^ "\n\n- new context:\n" - ^ eval_ctx_to_string ctx)); - failwith "Borrow not eliminated" - in - match lookup_loan_opt ek_all l ctx with - | None -> () (* Ok *) - | Some _ -> - log#lerror - (lazy - ("end borrow: " ^ V.BorrowId.to_string l - ^ ": loan didn't disappear:\n- original context:\n" - ^ eval_ctx_to_string ctx0 ^ "\n\n- new context:\n" - ^ eval_ctx_to_string ctx)); - failwith "Loan not eliminated" - in - let cf_check_disappeared : cm_fun = unit_to_cm_fun check_disappeared in - (* The complete sanity check: also check that after we ended a borrow, - * the invariant is preserved *) - let cf_check : cm_fun = - comp cf_check_disappeared (Invariants.cf_check_invariants config) - in - - (* Start by getting the borrow *) - match end_borrow_get_borrow allowed_abs l ctx with - (* Two cases: - * - error: we found outer borrows or inner loans (end them first) - * - success: we didn't find outer borrows when updating (but maybe we actually - didn't find the borrow we were looking for...) - *) - | Error priority -> ( - (* Debug *) - log#ldebug - (lazy - ("end borrow: " ^ V.BorrowId.to_string l - ^ ": found outer borrows/abs or inner loans:" - ^ show_priority_borrows_or_abs priority)); - (* End the priority borrows, abstraction, then try again to end the target - * borrow (if necessary) *) - match priority with - | OuterBorrows (Borrows bids) | InnerLoans (Borrows bids) -> - (* Note that we might get there with [allowed_abs <> None]: we might - * be trying to end a borrow inside an abstraction, but which is actually - * inside another borrow *) - let allowed_abs' = None in - (* End the outer borrows *) - let cc = end_borrows config chain allowed_abs' bids in - (* Retry to end the borrow *) - let cc = comp cc (end_borrow config chain0 allowed_abs l) in - (* Check and apply *) - comp cc cf_check cf ctx - | OuterBorrows (Borrow bid) | InnerLoans (Borrow bid) -> - let allowed_abs' = None in - (* End the outer borrow *) - let cc = end_borrow config chain allowed_abs' bid in - (* Retry to end the borrow *) - let cc = comp cc (end_borrow config chain0 allowed_abs l) in - (* Check and apply *) - comp cc cf_check cf ctx - | OuterAbs abs_id -> - (* The borrow is inside an asbtraction: check if the corresponding - * loan is inside the same abstraction. If this is the case, we end - * the borrow without ending the abstraction. If not, we need to - * end the whole abstraction *) - (* Note that we can lookup the loan anywhere *) - let ek = - { - enter_shared_loans = true; - enter_mut_borrows = true; - enter_abs = true; - } - in - let cf_end_abs : cm_fun = - match lookup_loan ek l ctx with - | AbsId loan_abs_id, _ -> - if loan_abs_id = abs_id then - (* Same abstraction! We can end the borrow *) - end_borrow config chain0 (Some abs_id) l - else - (* Not the same abstraction: we need to end the whole abstraction. - * By doing that we should have ended the target borrow (see the - * below sanity check) *) - end_abstraction config chain abs_id - | VarId _, _ -> - (* The loan is not inside the same abstraction (actually inside - * a non-abstraction value): we need to end the whole abstraction *) - end_abstraction config chain abs_id - in - (* Compose with a sanity check *) - comp cf_end_abs cf_check cf ctx) - | Ok (ctx, None) -> - log#ldebug (lazy "End borrow: borrow not found"); - (* It is possible that we can't find a borrow in symbolic mode (ending - * an abstraction may end several borrows at once *) - assert (config.mode = SymbolicMode); - (* Do a sanity check and continue *) - cf_check cf ctx - (* We found a borrow: give it back (i.e., update the corresponding loan) *) - | Ok (ctx, Some bc) -> - (* Sanity check: the borrowed value shouldn't contain loans *) - (match bc with - | Concrete (V.MutBorrow (_, bv)) -> - assert (Option.is_none (get_first_loan_in_value bv)) - | _ -> ()); - (* Give back the value *) - let ctx = give_back config l bc ctx in - (* Do a sanity check and continue *) - cf_check cf ctx - -and end_borrows (config : C.config) (chain : borrow_or_abs_ids) - (allowed_abs : V.AbstractionId.id option) (lset : V.BorrowId.Set.t) : cm_fun - = - fun cf -> - (* This is not necessary, but we prefer to reorder the borrow ids, - * so that we actually end from the smallest id to the highest id - just - * a matter of taste, and may make debugging easier *) - let ids = V.BorrowId.Set.fold (fun id ids -> id :: ids) lset [] in - List.fold_left (fun cf id -> end_borrow config chain allowed_abs id cf) cf ids - -and end_abstraction (config : C.config) (chain : borrow_or_abs_ids) - (abs_id : V.AbstractionId.id) : cm_fun = - fun cf ctx -> - (* Check that we don't loop *) - let chain = - add_borrow_or_abs_id_to_chain "end_abstraction: " (AbsId abs_id) chain - in - (* Remember the original context for printing purposes *) - let ctx0 = ctx in - log#ldebug - (lazy - ("end_abstraction: " - ^ V.AbstractionId.to_string abs_id - ^ "\n- original context:\n" ^ eval_ctx_to_string ctx0)); - - (* Lookup the abstraction *) - let abs = C.ctx_lookup_abs ctx abs_id in - - (* Check that we can end the abstraction *) - assert abs.can_end; - - (* End the parent abstractions first *) - let cc = end_abstractions config chain abs.parents in - let cc = - comp_unit cc (fun ctx -> - log#ldebug - (lazy - ("end_abstraction: " - ^ V.AbstractionId.to_string abs_id - ^ "\n- context after parent abstractions ended:\n" - ^ eval_ctx_to_string ctx))) - in - - (* End the loans inside the abstraction *) - let cc = comp cc (end_abstraction_loans config chain abs_id) in - let cc = - comp_unit cc (fun ctx -> - log#ldebug - (lazy - ("end_abstraction: " - ^ V.AbstractionId.to_string abs_id - ^ "\n- context after loans ended:\n" ^ eval_ctx_to_string ctx))) - in - - (* End the abstraction itself by redistributing the borrows it contains *) - let cc = comp cc (end_abstraction_borrows config chain abs_id) in - - (* End the regions owned by the abstraction - note that we don't need to - * relookup the abstraction: the set of regions in an abstraction never - * changes... *) - let cc = - comp_update cc (fun ctx -> - let ended_regions = - T.RegionId.Set.union ctx.ended_regions abs.V.regions - in - { ctx with ended_regions }) - in - - (* Remove all the references to the id of the current abstraction, and remove - * the abstraction itself. - * **Rk.**: this is where we synthesize the updated symbolic AST *) - let cc = comp cc (end_abstraction_remove_from_context config abs_id) in - - (* Debugging *) - let cc = - comp_unit cc (fun ctx -> - log#ldebug - (lazy - ("end_abstraction: " - ^ V.AbstractionId.to_string abs_id - ^ "\n- original context:\n" ^ eval_ctx_to_string ctx0 - ^ "\n\n- new context:\n" ^ eval_ctx_to_string ctx))) - in - - (* Sanity check: ending an abstraction must preserve the invariants *) - let cc = comp cc (Invariants.cf_check_invariants config) in - - (* Apply the continuation *) - cc cf ctx - -and end_abstractions (config : C.config) (chain : borrow_or_abs_ids) - (abs_ids : V.AbstractionId.Set.t) : cm_fun = - fun cf -> - (* This is not necessary, but we prefer to reorder the abstraction ids, - * so that we actually end from the smallest id to the highest id - just - * a matter of taste, and may make debugging easier *) - let abs_ids = V.AbstractionId.Set.fold (fun id ids -> id :: ids) abs_ids [] in - List.fold_left (fun cf id -> end_abstraction config chain id cf) cf abs_ids - -and end_abstraction_loans (config : C.config) (chain : borrow_or_abs_ids) - (abs_id : V.AbstractionId.id) : cm_fun = - fun cf ctx -> - (* Lookup the abstraction *) - let abs = C.ctx_lookup_abs ctx abs_id in - (* End the first loan we find. - * - * We ignore the "ignored mut/shared loans": as we should have already ended - * the parent abstractions, they necessarily come from children. *) - let opt_loan = get_first_non_ignored_aloan_in_abstraction abs in - match opt_loan with - | None -> - (* No loans: nothing to update *) - cf ctx - | Some (BorrowIds bids) -> - (* There are loans: end the corresponding borrows, then recheck *) - let cc : cm_fun = - match bids with - | Borrow bid -> end_borrow config chain None bid - | Borrows bids -> end_borrows config chain None bids - in - (* Reexplore, looking for loans *) - let cc = comp cc (end_abstraction_loans config chain abs_id) in - (* Continue *) - cc cf ctx - | Some (SymbolicValue sv) -> - (* There is a proj_loans over a symbolic value: end the proj_borrows - * which intersect this proj_loans, then end the proj_loans itself *) - let cc = end_proj_loans_symbolic config chain abs_id abs.regions sv in - (* Reexplore, looking for loans *) - let cc = comp cc (end_abstraction_loans config chain abs_id) in - (* Continue *) - cc cf ctx - -and end_abstraction_borrows (config : C.config) (chain : borrow_or_abs_ids) - (abs_id : V.AbstractionId.id) : cm_fun = - fun cf ctx -> - log#ldebug - (lazy - ("end_abstraction_borrows: abs_id: " ^ V.AbstractionId.to_string abs_id)); - (* Note that the abstraction mustn't contain any loans *) - (* We end the borrows, starting with the *inner* ones. This is important - when considering nested borrows which have the same lifetime. - TODO: is that really important? Initially, there was a concern about - whether we should give back ⊥ or not, but everything is handled by - the symbolic value expansion... Also, now we use the AEndedMutBorrow - values to store the children avalues (which was not the case before - we - initially replaced the ended mut borrows with ⊥). - *) - (* We explore in-depth and use exceptions. When exploring a borrow, if - * the exploration didn't trigger an exception, it means there are no - * inner borrows to end: we can thus trigger an exception for the current - * borrow. *) - let obj = - object - inherit [_] V.iter_abs as super - - method! visit_aborrow_content env bc = - (* In-depth exploration *) - super#visit_aborrow_content env bc; - (* No exception was raise: we can raise an exception for the - * current borrow *) - match bc with - | V.AMutBorrow (_, _, _) | V.ASharedBorrow _ -> - (* Raise an exception *) - raise (FoundABorrowContent bc) - | V.AProjSharedBorrow asb -> - (* Raise an exception only if the asb contains borrows *) - if - List.exists - (fun x -> match x with V.AsbBorrow _ -> true | _ -> false) - asb - then raise (FoundABorrowContent bc) - else () - | V.AEndedMutBorrow _ | V.AIgnoredMutBorrow _ - | V.AEndedIgnoredMutBorrow _ | V.AEndedSharedBorrow -> - (* Nothing to do for ignored borrows *) - () - - method! visit_aproj env sproj = - (match sproj with - | V.AProjLoans _ -> failwith "Unexpected" - | V.AProjBorrows (sv, proj_ty) -> - raise (FoundAProjBorrows (sv, proj_ty)) - | V.AEndedProjLoans _ | V.AEndedProjBorrows _ | V.AIgnoredProjBorrows -> - ()); - super#visit_aproj env sproj - - (** We may need to end borrows in "regular" values, because of shared values *) - method! visit_borrow_content _ bc = - match bc with - | V.SharedBorrow (_, _) | V.MutBorrow (_, _) -> - raise (FoundBorrowContent bc) - | V.InactivatedMutBorrow _ -> failwith "Unreachable" - end - in - (* Lookup the abstraction *) - let abs = C.ctx_lookup_abs ctx abs_id in - try - (* Explore the abstraction, looking for borrows *) - obj#visit_abs () abs; - (* No borrows: nothing to update *) - cf ctx - with - (* There are concrete (i.e., not symbolic) borrows: end them, then reexplore *) - | FoundABorrowContent bc -> - log#ldebug - (lazy - ("end_abstraction_borrows: found aborrow content: " - ^ aborrow_content_to_string ctx bc)); - let ctx = - match bc with - | V.AMutBorrow (_mv, bid, av) -> - (* First, convert the avalue to a (fresh symbolic) value *) - let sv = convert_avalue_to_given_back_value abs.kind av in - (* Replace the mut borrow to register the fact that we ended - * it and store with it the freshly generated given back value *) - let ended_borrow = V.ABorrow (V.AEndedMutBorrow (sv, av)) in - let ctx = update_aborrow ek_all bid ended_borrow ctx in - (* Give the value back *) - let sv = mk_typed_value_from_symbolic_value sv in - give_back_value config bid sv ctx - | V.ASharedBorrow bid -> - (* Replace the shared borrow to account for the fact it ended *) - let ended_borrow = V.ABorrow V.AEndedSharedBorrow in - let ctx = update_aborrow ek_all bid ended_borrow ctx in - (* Give back *) - give_back_shared config bid ctx - | V.AProjSharedBorrow asb -> - (* Retrieve the borrow ids *) - let bids = - List.filter_map - (fun asb -> - match asb with - | V.AsbBorrow bid -> Some bid - | V.AsbProjReborrows (_, _) -> None) - asb - in - (* There should be at least one borrow identifier in the set, which we - * can use to identify the whole set *) - let repr_bid = List.hd bids in - (* Replace the shared borrow with Bottom *) - let ctx = update_aborrow ek_all repr_bid V.ABottom ctx in - (* Give back the shared borrows *) - let ctx = - List.fold_left - (fun ctx bid -> give_back_shared config bid ctx) - ctx bids - in - (* Continue *) - ctx - | V.AEndedMutBorrow _ | V.AIgnoredMutBorrow _ - | V.AEndedIgnoredMutBorrow _ | V.AEndedSharedBorrow -> - failwith "Unexpected" - in - (* Reexplore *) - end_abstraction_borrows config chain abs_id cf ctx - (* There are symbolic borrows: end them, then reexplore *) - | FoundAProjBorrows (sv, proj_ty) -> - log#ldebug - (lazy - ("end_abstraction_borrows: found aproj borrows: " - ^ aproj_to_string ctx (V.AProjBorrows (sv, proj_ty)))); - (* Generate a fresh symbolic value *) - let nsv = mk_fresh_symbolic_value V.FunCallGivenBack proj_ty in - (* Replace the proj_borrows - there should be exactly one *) - let ended_borrow = V.AEndedProjBorrows nsv in - let ctx = update_aproj_borrows abs.abs_id sv ended_borrow ctx in - (* Give back the symbolic value *) - let ctx = - give_back_symbolic_value config abs.regions proj_ty sv nsv ctx - in - (* Reexplore *) - end_abstraction_borrows config chain abs_id cf ctx - (* There are concrete (i.e., not symbolic) borrows in shared values: end them, then reexplore *) - | FoundBorrowContent bc -> - log#ldebug - (lazy - ("end_abstraction_borrows: found borrow content: " - ^ borrow_content_to_string ctx bc)); - let ctx = - match bc with - | V.SharedBorrow (_, bid) -> ( - (* Replace the shared borrow with bottom *) - match end_borrow_get_borrow (Some abs_id) bid ctx with - | Error _ -> failwith "Unreachable" - | Ok (ctx, _) -> - (* Give back *) - give_back_shared config bid ctx) - | V.MutBorrow (bid, v) -> ( - (* Replace the mut borrow with bottom *) - match end_borrow_get_borrow (Some abs_id) bid ctx with - | Error _ -> failwith "Unreachable" - | Ok (ctx, _) -> - (* Give the value back - note that the mut borrow was below a - * shared borrow: the value is thus unchanged *) - give_back_value config bid v ctx) - | V.InactivatedMutBorrow _ -> failwith "Unreachable" - in - (* Reexplore *) - end_abstraction_borrows config chain abs_id cf ctx - -(** Remove an abstraction from the context, as well as all its references *) -and end_abstraction_remove_from_context (_config : C.config) - (abs_id : V.AbstractionId.id) : cm_fun = - fun cf ctx -> - let rec remove_from_env (env : C.env) : C.env * V.abs option = - match env with - | [] -> failwith "Unreachable" - | C.Frame :: _ -> (env, None) - | Var (bv, v) :: env -> - let env, abs_opt = remove_from_env env in - (Var (bv, v) :: env, abs_opt) - | C.Abs abs :: env -> - if abs.abs_id = abs_id then (env, Some abs) - else - let env, abs_opt = remove_from_env env in - let parents = V.AbstractionId.Set.remove abs_id abs.parents in - (C.Abs { abs with V.parents } :: env, abs_opt) - in - let env, abs = remove_from_env ctx.C.env in - let ctx = { ctx with C.env } in - let abs = Option.get abs in - (* Apply the continuation *) - let expr = cf ctx in - (* Synthesize the symbolic AST *) - S.synthesize_end_abstraction abs expr - -(** End a proj_loan over a symbolic value by ending the proj_borrows which - intersect this proj_loans. - - Rk.: - - if this symbolic value is primitively copiable, then: - - either proj_borrows are only present in the concrete context - - or there is only one intersecting proj_borrow present in an - abstraction - - otherwise, this symbolic value is not primitively copiable: - - there may be proj_borrows_shared over this value - - if we put aside the proj_borrows_shared, there should be exactly one - intersecting proj_borrows, either in the concrete context or in an - abstraction -*) -and end_proj_loans_symbolic (config : C.config) (chain : borrow_or_abs_ids) - (abs_id : V.AbstractionId.id) (regions : T.RegionId.Set.t) - (sv : V.symbolic_value) : cm_fun = - fun cf ctx -> - (* Small helpers for sanity checks *) - let check ctx = no_aproj_over_symbolic_in_context sv ctx in - let cf_check (cf : m_fun) : m_fun = - fun ctx -> - check ctx; - cf ctx - in - (* Find the first proj_borrows which intersects the proj_loans *) - let explore_shared = true in - match lookup_intersecting_aproj_borrows_opt explore_shared regions sv ctx with - | None -> - (* We couldn't find any in the context: it means that the symbolic value - * is in the concrete environment (or that we dropped it, in which case - * it is completely absent). We thus simply need to replace the loans - * projector with an ended projector. *) - let ctx = update_aproj_loans_to_ended abs_id sv ctx in - (* Sanity check *) - check ctx; - (* Continue *) - cf ctx - | Some (SharedProjs projs) -> - (* We found projectors over shared values - split between the projectors - which belong to the current abstraction and the others. - The context looks like this: - {[ - abs'0 { - // The loan was initially like this: - // [shared_loan lids (s <: ...) [s]] - // but if we get there it means it was already ended: - ended_shared_loan (s <: ...) [s] - proj_shared_borrows [...; (s <: ...); ...] - proj_shared_borrows [...; (s <: ...); ...] - ... - } - - abs'1 [ - proj_shared_borrows [...; (s <: ...); ...] - ... - } - - ... - - // No [s] outside of abstractions - - ]} - *) - let _owned_projs, external_projs = - List.partition (fun (abs_id', _) -> abs_id' = abs_id) projs - in - (* End the external borrow projectors (end their abstractions) *) - let cf_end_external : cm_fun = - fun cf ctx -> - let abs_ids = List.map fst external_projs in - let abs_ids = - List.fold_left - (fun s id -> V.AbstractionId.Set.add id s) - V.AbstractionId.Set.empty abs_ids - in - (* End the abstractions and continue *) - end_abstractions config chain abs_ids cf ctx - in - (* End the internal borrows projectors and the loans projector *) - let cf_end_internal : cm_fun = - fun cf ctx -> - (* All the proj_borrows are owned: simply erase them *) - let ctx = remove_intersecting_aproj_borrows_shared regions sv ctx in - (* End the loan itself *) - let ctx = update_aproj_loans_to_ended abs_id sv ctx in - (* Sanity check *) - check ctx; - (* Continue *) - cf ctx - in - (* Compose and apply *) - let cc = comp cf_end_external cf_end_internal in - cc cf ctx - | Some (NonSharedProj (abs_id', _proj_ty)) -> - (* We found one projector of borrows in an abstraction: if it comes - * from this abstraction, we can end it directly, otherwise we need - * to end the abstraction where it came from first *) - if abs_id' = abs_id then ( - (* Note that it happens when a function returns a [&mut ...] which gets - expanded to [mut_borrow l s], and we end the borrow [l] (so [s] gets - reinjected in the parent abstraction without having been modified). - - The context looks like this: - {[ - abs'0 { - [s <: ...] - (s <: ...) - } - - // Note that [s] can't appear in other abstractions or in the - // regular environment (because we forbid the duplication of - // symbolic values which contain borrows). - ]} - *) - (* End the projector of borrows - TODO: not completely sure what to - * replace it with... Maybe we should introduce an ABottomProj? *) - let ctx = update_aproj_borrows abs_id sv V.AIgnoredProjBorrows ctx in - (* Sanity check: no other occurrence of an intersecting projector of borrows *) - assert ( - Option.is_none - (lookup_intersecting_aproj_borrows_opt explore_shared regions sv ctx)); - (* End the projector of loans *) - let ctx = update_aproj_loans_to_ended abs_id sv ctx in - (* Sanity check *) - check ctx; - (* Continue *) - cf ctx) - else - (* The borrows proj comes from a different abstraction: end it. *) - let cc = end_abstraction config chain abs_id' in - (* Retry ending the projector of loans *) - let cc = - comp cc (end_proj_loans_symbolic config chain abs_id regions sv) - in - (* Sanity check *) - let cc = comp cc cf_check in - (* Continue *) - cc cf ctx - -let end_outer_borrow config : V.BorrowId.id -> cm_fun = - end_borrow config [] None - -let end_outer_borrows config : V.BorrowId.Set.t -> cm_fun = - end_borrows config [] None - -(** Helper function: see [activate_inactivated_mut_borrow]. - - This function updates the shared loan to a mutable loan (we then update - the borrow with another helper). Of course, the shared loan must contain - exactly one borrow id (the one we give as parameter), otherwise we can't - promote it. Also, the shared value mustn't contain any loan. - - The returned value (previously shared) is checked: - - it mustn't contain loans - - it mustn't contain {!V.Bottom} - - it mustn't contain inactivated borrows - TODO: this kind of checks should be put in an auxiliary helper, because - they are redundant. - - The loan to update mustn't be a borrowed value. - *) -let promote_shared_loan_to_mut_loan (l : V.BorrowId.id) - (cf : V.typed_value -> m_fun) : m_fun = - fun ctx -> - (* Debug *) - log#ldebug - (lazy - ("promote_shared_loan_to_mut_loan:\n- loan: " ^ V.BorrowId.to_string l - ^ "\n- context:\n" ^ eval_ctx_to_string ctx ^ "\n")); - (* Lookup the shared loan - note that we can't promote a shared loan - * in a shared value, but we can do it in a mutably borrowed value. - * This is important because we can do: [let y = &two-phase ( *x );] - *) - let ek = - { enter_shared_loans = false; enter_mut_borrows = true; enter_abs = false } - in - match lookup_loan ek l ctx with - | _, Concrete (V.MutLoan _) -> - failwith "Expected a shared loan, found a mut loan" - | _, Concrete (V.SharedLoan (bids, sv)) -> - (* Check that there is only one borrow id (l) and update the loan *) - assert (V.BorrowId.Set.mem l bids && V.BorrowId.Set.cardinal bids = 1); - (* We need to check that there aren't any loans in the value: - we should have gotten rid of those already, but it is better - to do a sanity check. *) - assert (not (loans_in_value sv)); - (* Check there isn't {!Bottom} (this is actually an invariant *) - assert (not (bottom_in_value ctx.ended_regions sv)); - (* Check there aren't inactivated borrows *) - assert (not (inactivated_in_value sv)); - (* Update the loan content *) - let ctx = update_loan ek l (V.MutLoan l) ctx in - (* Continue *) - cf sv ctx - | _, Abstract _ -> - (* I don't think it is possible to have two-phase borrows involving borrows - * returned by abstractions. I'm not sure how we could handle that anyway. *) - failwith - "Can't promote a shared loan to a mutable loan if the loan is inside \ - an abstraction" - -(** Helper function: see {!activate_inactivated_mut_borrow}. - - This function updates a shared borrow to a mutable borrow. - *) -let promote_inactivated_borrow_to_mut_borrow (l : V.BorrowId.id) (cf : m_fun) - (borrowed_value : V.typed_value) : m_fun = - fun ctx -> - (* Lookup the inactivated borrow - note that we don't go inside borrows/loans: - there can't be inactivated borrows inside other borrows/loans - *) - let ek = - { enter_shared_loans = false; enter_mut_borrows = false; enter_abs = false } - in - let ctx = - match lookup_borrow ek l ctx with - | Concrete (V.SharedBorrow _ | V.MutBorrow (_, _)) -> - failwith "Expected an inactivated mutable borrow" - | Concrete (V.InactivatedMutBorrow _) -> - (* Update it *) - update_borrow ek l (V.MutBorrow (l, borrowed_value)) ctx - | Abstract _ -> - (* This can't happen for sure *) - failwith - "Can't promote a shared borrow to a mutable borrow if the borrow is \ - inside an abstraction" - in - (* Continue *) - cf ctx - -(** Promote an inactivated mut borrow to a mut borrow. - - The borrow must point to a shared value which is borrowed exactly once. - *) -let rec activate_inactivated_mut_borrow (config : C.config) (l : V.BorrowId.id) - : cm_fun = - fun cf ctx -> - (* Lookup the value *) - let ek = - { enter_shared_loans = false; enter_mut_borrows = true; enter_abs = false } - in - match lookup_loan ek l ctx with - | _, Concrete (V.MutLoan _) -> failwith "Unreachable" - | _, Concrete (V.SharedLoan (bids, sv)) -> ( - (* If there are loans inside the value, end them. Note that there can't be - inactivated borrows inside the value. - If we perform an update, do a recursive call to lookup the updated value *) - match get_first_loan_in_value sv with - | Some lc -> - (* End the loans *) - let cc = - match lc with - | V.SharedLoan (bids, _) -> end_outer_borrows config bids - | V.MutLoan bid -> end_outer_borrow config bid - in - (* Recursive call *) - let cc = comp cc (activate_inactivated_mut_borrow config l) in - (* Continue *) - cc cf ctx - | None -> - (* No loan to end inside the value *) - (* Some sanity checks *) - log#ldebug - (lazy - ("activate_inactivated_mut_borrow: resulting value:\n" - ^ typed_value_to_string ctx sv)); - assert (not (loans_in_value sv)); - assert (not (bottom_in_value ctx.ended_regions sv)); - assert (not (inactivated_in_value sv)); - (* End the borrows which borrow from the value, at the exception of - the borrow we want to promote *) - let bids = V.BorrowId.Set.remove l bids in - let cc = end_outer_borrows config bids in - (* Promote the loan - TODO: this will fail if the value contains - * any loans. In practice, it shouldn't, but we could also - * look for loans inside the value and end them before promoting - * the borrow. *) - let cc = comp cc (promote_shared_loan_to_mut_loan l) in - (* Promote the borrow - the value should have been checked by - {!promote_shared_loan_to_mut_loan} - *) - let cc = - comp cc (fun cf borrowed_value -> - promote_inactivated_borrow_to_mut_borrow l cf borrowed_value) - in - (* Continue *) - cc cf ctx) - | _, Abstract _ -> - (* I don't think it is possible to have two-phase borrows involving borrows - * returned by abstractions. I'm not sure how we could handle that anyway. *) - failwith - "Can't activate an inactivated mutable borrow referencing a loan inside\n\ - \ an abstraction" diff --git a/src/InterpreterBorrowsCore.ml b/src/InterpreterBorrowsCore.ml deleted file mode 100644 index a5501712..00000000 --- a/src/InterpreterBorrowsCore.ml +++ /dev/null @@ -1,1181 +0,0 @@ -(* This file defines the basic blocks to implement the semantics of borrows. - * Note that those functions are not only used in InterpreterBorrows, but - * also in Invariants or InterpreterProjectors *) - -module T = Types -module V = Values -module C = Contexts -module Subst = Substitute -module L = Logging -open Utils -open TypesUtils -open InterpreterUtils - -(** The local logger *) -let log = L.borrows_log - -(** TODO: cleanup this a bit, once we have a better understanding about - what we need. - TODO: I'm not sure in which file this should be moved... *) -type exploration_kind = { - enter_shared_loans : bool; - enter_mut_borrows : bool; - enter_abs : bool; - (** Note that if we allow to enter abs, we don't check whether we enter - mutable/shared loans or borrows: there are no use cases requiring - a finer control. *) -} -(** This record controls how some generic helper lookup/update - functions behave, by restraining the kind of therms they can enter. -*) - -let ek_all : exploration_kind = - { enter_shared_loans = true; enter_mut_borrows = true; enter_abs = true } - -type borrow_ids = Borrows of V.BorrowId.Set.t | Borrow of V.BorrowId.id -[@@deriving show] - -exception FoundBorrowIds of borrow_ids - -type priority_borrows_or_abs = - | OuterBorrows of borrow_ids - | OuterAbs of V.AbstractionId.id - | InnerLoans of borrow_ids -[@@deriving show] - -type borrow_ids_or_symbolic_value = - | BorrowIds of borrow_ids - | SymbolicValue of V.symbolic_value -[@@deriving show] - -let update_if_none opt x = match opt with None -> Some x | _ -> opt - -(** Utility exception *) -exception FoundPriority of priority_borrows_or_abs - -type loan_or_borrow_content = - | LoanContent of V.loan_content - | BorrowContent of V.borrow_content -[@@deriving show] - -type borrow_or_abs_id = - | BorrowId of V.BorrowId.id - | AbsId of V.AbstractionId.id - -type borrow_or_abs_ids = borrow_or_abs_id list - -let borrow_or_abs_id_to_string (id : borrow_or_abs_id) : string = - match id with - | AbsId id -> "abs@" ^ V.AbstractionId.to_string id - | BorrowId id -> "l@" ^ V.BorrowId.to_string id - -let borrow_or_abs_ids_chain_to_string (ids : borrow_or_abs_ids) : string = - let ids = List.rev ids in - let ids = List.map borrow_or_abs_id_to_string ids in - String.concat " -> " ids - -(** Add a borrow or abs id to a chain of ids, while checking that we don't loop *) -let add_borrow_or_abs_id_to_chain (msg : string) (id : borrow_or_abs_id) - (ids : borrow_or_abs_ids) : borrow_or_abs_ids = - if List.mem id ids then - failwith - (msg ^ "detected a loop in the chain of ids: " - ^ borrow_or_abs_ids_chain_to_string (id :: ids)) - else id :: ids - -(** Helper function. - - This function allows to define in a generic way a comparison of region types. - See [projections_interesect] for instance. - - [default]: default boolean to return, when comparing types with no regions - [combine]: how to combine booleans - [compare_regions]: how to compare regions - *) -let rec compare_rtys (default : bool) (combine : bool -> bool -> bool) - (compare_regions : T.RegionId.id T.region -> T.RegionId.id T.region -> bool) - (ty1 : T.rty) (ty2 : T.rty) : bool = - let compare = compare_rtys default combine compare_regions in - match (ty1, ty2) with - | T.Bool, T.Bool | T.Char, T.Char | T.Str, T.Str -> default - | T.Integer int_ty1, T.Integer int_ty2 -> - assert (int_ty1 = int_ty2); - default - | T.Adt (id1, regions1, tys1), T.Adt (id2, regions2, tys2) -> - assert (id1 = id2); - - (* The check for the ADTs is very crude: we simply compare the arguments - * two by two. - * - * For instance, when checking if some projections intersect, we simply - * check if some arguments intersect. As all the type and region - * parameters should be used somewhere in the ADT (otherwise rustc - * generates an error), it means that it should be equivalent to checking - * whether two fields intersect (and anyway comparing the field types is - * difficult in case of enumerations...). - * If we didn't have the above property enforced by the rust compiler, - * this check would still be a reasonable conservative approximation. *) - - (* Check the region parameters *) - let regions = List.combine regions1 regions2 in - let params_b = - List.fold_left - (fun b (r1, r2) -> combine b (compare_regions r1 r2)) - default regions - in - (* Check the type parameters *) - let tys = List.combine tys1 tys2 in - let tys_b = - List.fold_left - (fun b (ty1, ty2) -> combine b (compare ty1 ty2)) - default tys - in - (* Combine *) - combine params_b tys_b - | T.Array ty1, T.Array ty2 | T.Slice ty1, T.Slice ty2 -> compare ty1 ty2 - | T.Ref (r1, ty1, kind1), T.Ref (r2, ty2, kind2) -> - (* Sanity check *) - assert (kind1 = kind2); - (* Explanation for the case where we check if projections intersect: - * the projections intersect if the borrows intersect or their contents - * intersect. *) - let regions_b = compare_regions r1 r2 in - let tys_b = compare ty1 ty2 in - combine regions_b tys_b - | T.TypeVar id1, T.TypeVar id2 -> - assert (id1 = id2); - default - | _ -> - log#lerror - (lazy - ("compare_rtys: unexpected inputs:" ^ "\n- ty1: " ^ T.show_rty ty1 - ^ "\n- ty2: " ^ T.show_rty ty2)); - failwith "Unreachable" - -(** Check if two different projections intersect. This is necessary when - giving a symbolic value to an abstraction: we need to check that - the regions which are already ended inside the abstraction don't - intersect the regions over which we project in the new abstraction. - Note that the two abstractions have different views (in terms of regions) - of the symbolic value (hence the two region types). -*) -let projections_intersect (ty1 : T.rty) (rset1 : T.RegionId.Set.t) (ty2 : T.rty) - (rset2 : T.RegionId.Set.t) : bool = - let default = false in - let combine b1 b2 = b1 || b2 in - let compare_regions r1 r2 = - region_in_set r1 rset1 && region_in_set r2 rset2 - in - compare_rtys default combine compare_regions ty1 ty2 - -(** Check if the first projection contains the second projection. - We use this function when checking invariants. -*) -let projection_contains (ty1 : T.rty) (rset1 : T.RegionId.Set.t) (ty2 : T.rty) - (rset2 : T.RegionId.Set.t) : bool = - let default = true in - let combine b1 b2 = b1 && b2 in - let compare_regions r1 r2 = - region_in_set r1 rset1 || not (region_in_set r2 rset2) - in - compare_rtys default combine compare_regions ty1 ty2 - -(** Lookup a loan content. - - The loan is referred to by a borrow id. - - TODO: group abs_or_var_id and g_loan_content. - *) -let lookup_loan_opt (ek : exploration_kind) (l : V.BorrowId.id) - (ctx : C.eval_ctx) : (abs_or_var_id * g_loan_content) option = - (* We store here whether we are inside an abstraction or a value - note that we - * could also track that with the environment, it would probably be more idiomatic - * and cleaner *) - let abs_or_var : abs_or_var_id option ref = ref None in - - let obj = - object - inherit [_] C.iter_eval_ctx as super - - method! visit_borrow_content env bc = - match bc with - | V.SharedBorrow (mv, bid) -> - (* Nothing specific to do *) - super#visit_SharedBorrow env mv bid - | V.InactivatedMutBorrow (mv, bid) -> - (* Nothing specific to do *) - super#visit_InactivatedMutBorrow env mv bid - | V.MutBorrow (bid, mv) -> - (* Control the dive *) - if ek.enter_mut_borrows then super#visit_MutBorrow env bid mv - else () - - (** We reimplement {!visit_Loan} (rather than the more precise functions - {!visit_SharedLoan}, etc.) on purpose: as we have an exhaustive match - below, we are more resilient to definition updates (the compiler - is our friend). - *) - method! visit_loan_content env lc = - match lc with - | V.SharedLoan (bids, sv) -> - (* Check if this is the loan we are looking for, and control the dive *) - if V.BorrowId.Set.mem l bids then - raise (FoundGLoanContent (Concrete lc)) - else if ek.enter_shared_loans then - super#visit_SharedLoan env bids sv - else () - | V.MutLoan bid -> - (* Check if this is the loan we are looking for *) - if bid = l then raise (FoundGLoanContent (Concrete lc)) - else super#visit_MutLoan env bid - - (** Note that we don't control diving inside the abstractions: if we - allow to dive inside abstractions, we allow to go anywhere - (because there are no use cases requiring finer control) *) - method! visit_aloan_content env lc = - match lc with - | V.AMutLoan (bid, av) -> - if bid = l then raise (FoundGLoanContent (Abstract lc)) - else super#visit_AMutLoan env bid av - | V.ASharedLoan (bids, v, av) -> - if V.BorrowId.Set.mem l bids then - raise (FoundGLoanContent (Abstract lc)) - else super#visit_ASharedLoan env bids v av - | V.AEndedMutLoan { given_back = _; child = _; given_back_meta = _ } - | V.AEndedSharedLoan (_, _) - | V.AIgnoredMutLoan (_, _) - | V.AEndedIgnoredMutLoan - { given_back = _; child = _; given_back_meta = _ } - | V.AIgnoredSharedLoan _ -> - super#visit_aloan_content env lc - - method! visit_Var env bv v = - assert (Option.is_none !abs_or_var); - abs_or_var := - Some - (VarId (match bv with Some bv -> Some bv.C.index | None -> None)); - super#visit_Var env bv v; - abs_or_var := None - - method! visit_Abs env abs = - assert (Option.is_none !abs_or_var); - if ek.enter_abs then ( - abs_or_var := Some (AbsId abs.V.abs_id); - super#visit_Abs env abs; - abs_or_var := None) - else () - end - in - (* We use exceptions *) - try - obj#visit_eval_ctx () ctx; - None - with FoundGLoanContent lc -> ( - match !abs_or_var with - | Some abs_or_var -> Some (abs_or_var, lc) - | None -> raise (Failure "Inconsistent state")) - -(** Lookup a loan content. - - The loan is referred to by a borrow id. - Raises an exception if no loan was found. - *) -let lookup_loan (ek : exploration_kind) (l : V.BorrowId.id) (ctx : C.eval_ctx) : - abs_or_var_id * g_loan_content = - match lookup_loan_opt ek l ctx with - | None -> failwith "Unreachable" - | Some res -> res - -(** Update a loan content. - - The loan is referred to by a borrow id. - - This is a helper function: it might break invariants. - *) -let update_loan (ek : exploration_kind) (l : V.BorrowId.id) - (nlc : V.loan_content) (ctx : C.eval_ctx) : C.eval_ctx = - (* We use a reference to check that we update exactly one loan: when updating - * inside values, we check we don't update more than one loan. Then, upon - * returning we check that we updated at least once. *) - let r = ref false in - let update () : V.loan_content = - assert (not !r); - r := true; - nlc - in - - let obj = - object - inherit [_] C.map_eval_ctx as super - - method! visit_borrow_content env bc = - match bc with - | V.SharedBorrow (_, _) | V.InactivatedMutBorrow _ -> - (* Nothing specific to do *) - super#visit_borrow_content env bc - | V.MutBorrow (bid, mv) -> - (* Control the dive into mutable borrows *) - if ek.enter_mut_borrows then super#visit_MutBorrow env bid mv - else V.MutBorrow (bid, mv) - - (** We reimplement {!visit_loan_content} (rather than one of the sub- - functions) on purpose: exhaustive matches are good for maintenance *) - method! visit_loan_content env lc = - match lc with - | V.SharedLoan (bids, sv) -> - (* Shared loan: check if this is the loan we are looking for, and - control the dive. *) - if V.BorrowId.Set.mem l bids then update () - else if ek.enter_shared_loans then - super#visit_SharedLoan env bids sv - else V.SharedLoan (bids, sv) - | V.MutLoan bid -> - (* Mut loan: checks if this is the loan we are looking for *) - if bid = l then update () else super#visit_MutLoan env bid - - (** Note that once inside the abstractions, we don't control diving - (there are no use cases requiring finer control). - Also, as we give back a {!loan_content} (and not an {!aloan_content}) - we don't need to do reimplement the visit functions for the values - inside the abstractions (rk.: there may be "concrete" values inside - abstractions, so there is a utility in diving inside). *) - method! visit_abs env abs = - if ek.enter_abs then super#visit_abs env abs else abs - end - in - - let ctx = obj#visit_eval_ctx () ctx in - (* Check that we updated at least one loan *) - assert !r; - ctx - -(** Update a abstraction loan content. - - The loan is referred to by a borrow id. - - This is a helper function: it might break invariants. - *) -let update_aloan (ek : exploration_kind) (l : V.BorrowId.id) - (nlc : V.aloan_content) (ctx : C.eval_ctx) : C.eval_ctx = - (* We use a reference to check that we update exactly one loan: when updating - * inside values, we check we don't update more than one loan. Then, upon - * returning we check that we updated at least once. *) - let r = ref false in - let update () : V.aloan_content = - assert (not !r); - r := true; - nlc - in - - let obj = - object - inherit [_] C.map_eval_ctx as super - - method! visit_aloan_content env lc = - match lc with - | V.AMutLoan (bid, av) -> - if bid = l then update () else super#visit_AMutLoan env bid av - | V.ASharedLoan (bids, v, av) -> - if V.BorrowId.Set.mem l bids then update () - else super#visit_ASharedLoan env bids v av - | V.AEndedMutLoan { given_back = _; child = _; given_back_meta = _ } - | V.AEndedSharedLoan (_, _) - | V.AIgnoredMutLoan (_, _) - | V.AEndedIgnoredMutLoan - { given_back = _; child = _; given_back_meta = _ } - | V.AIgnoredSharedLoan _ -> - super#visit_aloan_content env lc - - (** Note that once inside the abstractions, we don't control diving - (there are no use cases requiring finer control). *) - method! visit_abs env abs = - if ek.enter_abs then super#visit_abs env abs else abs - end - in - - let ctx = obj#visit_eval_ctx () ctx in - (* Check that we updated at least one loan *) - assert !r; - ctx - -(** Lookup a borrow content from a borrow id. *) -let lookup_borrow_opt (ek : exploration_kind) (l : V.BorrowId.id) - (ctx : C.eval_ctx) : g_borrow_content option = - let obj = - object - inherit [_] C.iter_eval_ctx as super - - method! visit_borrow_content env bc = - match bc with - | V.MutBorrow (bid, mv) -> - (* Check the borrow id and control the dive *) - if bid = l then raise (FoundGBorrowContent (Concrete bc)) - else if ek.enter_mut_borrows then super#visit_MutBorrow env bid mv - else () - | V.SharedBorrow (_, bid) -> - (* Check the borrow id *) - if bid = l then raise (FoundGBorrowContent (Concrete bc)) else () - | V.InactivatedMutBorrow (_, bid) -> - (* Check the borrow id *) - if bid = l then raise (FoundGBorrowContent (Concrete bc)) else () - - method! visit_loan_content env lc = - match lc with - | V.MutLoan bid -> - (* Nothing special to do *) super#visit_MutLoan env bid - | V.SharedLoan (bids, sv) -> - (* Control the dive *) - if ek.enter_shared_loans then super#visit_SharedLoan env bids sv - else () - - method! visit_aborrow_content env bc = - match bc with - | V.AMutBorrow (mv, bid, av) -> - if bid = l then raise (FoundGBorrowContent (Abstract bc)) - else super#visit_AMutBorrow env mv bid av - | V.ASharedBorrow bid -> - if bid = l then raise (FoundGBorrowContent (Abstract bc)) - else super#visit_ASharedBorrow env bid - | V.AIgnoredMutBorrow (_, _) - | V.AEndedMutBorrow _ - | V.AEndedIgnoredMutBorrow - { given_back_loans_proj = _; child = _; given_back_meta = _ } - | V.AEndedSharedBorrow -> - super#visit_aborrow_content env bc - | V.AProjSharedBorrow asb -> - if borrow_in_asb l asb then - raise (FoundGBorrowContent (Abstract bc)) - else () - - method! visit_abs env abs = - if ek.enter_abs then super#visit_abs env abs else () - end - in - (* We use exceptions *) - try - obj#visit_eval_ctx () ctx; - None - with FoundGBorrowContent lc -> Some lc - -(** Lookup a borrow content from a borrow id. - - Raise an exception if no loan was found -*) -let lookup_borrow (ek : exploration_kind) (l : V.BorrowId.id) (ctx : C.eval_ctx) - : g_borrow_content = - match lookup_borrow_opt ek l ctx with - | None -> failwith "Unreachable" - | Some lc -> lc - -(** Update a borrow content. - - The borrow is referred to by a borrow id. - - This is a helper function: it might break invariants. - *) -let update_borrow (ek : exploration_kind) (l : V.BorrowId.id) - (nbc : V.borrow_content) (ctx : C.eval_ctx) : C.eval_ctx = - (* We use a reference to check that we update exactly one borrow: when updating - * inside values, we check we don't update more than one borrow. Then, upon - * returning we check that we updated at least once. *) - let r = ref false in - let update () : V.borrow_content = - assert (not !r); - r := true; - nbc - in - - let obj = - object - inherit [_] C.map_eval_ctx as super - - method! visit_borrow_content env bc = - match bc with - | V.MutBorrow (bid, mv) -> - (* Check the id and control dive *) - if bid = l then update () - else if ek.enter_mut_borrows then super#visit_MutBorrow env bid mv - else V.MutBorrow (bid, mv) - | V.SharedBorrow (mv, bid) -> - (* Check the id *) - if bid = l then update () else super#visit_SharedBorrow env mv bid - | V.InactivatedMutBorrow (mv, bid) -> - (* Check the id *) - if bid = l then update () - else super#visit_InactivatedMutBorrow env mv bid - - method! visit_loan_content env lc = - match lc with - | V.SharedLoan (bids, sv) -> - (* Control the dive *) - if ek.enter_shared_loans then super#visit_SharedLoan env bids sv - else V.SharedLoan (bids, sv) - | V.MutLoan bid -> - (* Nothing specific to do *) - super#visit_MutLoan env bid - - method! visit_abs env abs = - if ek.enter_abs then super#visit_abs env abs else abs - end - in - - let ctx = obj#visit_eval_ctx () ctx in - (* Check that we updated at least one borrow *) - assert !r; - ctx - -(** Update an abstraction borrow content. - - The borrow is referred to by a borrow id. - - This is a helper function: it might break invariants. - *) -let update_aborrow (ek : exploration_kind) (l : V.BorrowId.id) (nv : V.avalue) - (ctx : C.eval_ctx) : C.eval_ctx = - (* We use a reference to check that we update exactly one borrow: when updating - * inside values, we check we don't update more than one borrow. Then, upon - * returning we check that we updated at least once. *) - let r = ref false in - let update () : V.avalue = - assert (not !r); - r := true; - nv - in - - let obj = - object - inherit [_] C.map_eval_ctx as super - - method! visit_ABorrow env bc = - match bc with - | V.AMutBorrow (mv, bid, av) -> - if bid = l then update () - else V.ABorrow (super#visit_AMutBorrow env mv bid av) - | V.ASharedBorrow bid -> - if bid = l then update () - else V.ABorrow (super#visit_ASharedBorrow env bid) - | V.AIgnoredMutBorrow _ | V.AEndedMutBorrow _ | V.AEndedSharedBorrow - | V.AEndedIgnoredMutBorrow _ -> - super#visit_ABorrow env bc - | V.AProjSharedBorrow asb -> - if borrow_in_asb l asb then update () - else V.ABorrow (super#visit_AProjSharedBorrow env asb) - - method! visit_abs env abs = - if ek.enter_abs then super#visit_abs env abs else abs - end - in - - let ctx = obj#visit_eval_ctx () ctx in - (* Check that we updated at least one borrow *) - assert !r; - ctx - -(** Auxiliary function: see its usage in [end_borrow_get_borrow_in_value] *) -let update_outer_borrows (outer : V.AbstractionId.id option * borrow_ids option) - (x : borrow_ids) : V.AbstractionId.id option * borrow_ids option = - let abs, opt = outer in - (abs, update_if_none opt x) - -(** Return the first loan we find in a value *) -let get_first_loan_in_value (v : V.typed_value) : V.loan_content option = - let obj = - object - inherit [_] V.iter_typed_value - method! visit_loan_content _ lc = raise (FoundLoanContent lc) - end - in - (* We use exceptions *) - try - obj#visit_typed_value () v; - None - with FoundLoanContent lc -> Some lc - -(** Return the first borrow we find in a value *) -let get_first_borrow_in_value (v : V.typed_value) : V.borrow_content option = - let obj = - object - inherit [_] V.iter_typed_value - method! visit_borrow_content _ bc = raise (FoundBorrowContent bc) - end - in - (* We use exceptions *) - try - obj#visit_typed_value () v; - None - with FoundBorrowContent bc -> Some bc - -(** Return the first loan or borrow content we find in a value (starting with - the outer ones). - - [with_borrows]: - - if true: return the first loan or borrow we find - - if false: return the first loan we find, do not dive into borrowed values - *) -let get_first_outer_loan_or_borrow_in_value (with_borrows : bool) - (v : V.typed_value) : loan_or_borrow_content option = - let obj = - object - inherit [_] V.iter_typed_value - - method! visit_borrow_content _ bc = - if with_borrows then raise (FoundBorrowContent bc) else () - - method! visit_loan_content _ lc = raise (FoundLoanContent lc) - end - in - (* We use exceptions *) - try - obj#visit_typed_value () v; - None - with - | FoundLoanContent lc -> Some (LoanContent lc) - | FoundBorrowContent bc -> Some (BorrowContent bc) - -type gproj_borrows = - | AProjBorrows of V.AbstractionId.id * V.symbolic_value - | ProjBorrows of V.symbolic_value - -let proj_borrows_intersects_proj_loans - (proj_borrows : T.RegionId.Set.t * V.symbolic_value * T.rty) - (proj_loans : T.RegionId.Set.t * V.symbolic_value) : bool = - let b_regions, b_sv, b_ty = proj_borrows in - let l_regions, l_sv = proj_loans in - if same_symbolic_id b_sv l_sv then - projections_intersect l_sv.V.sv_ty l_regions b_ty b_regions - else false - -(** Result of looking up aproj_borrows which intersect a given aproj_loans in - the context. - - Note that because we we force the expansion of primitively copyable values - before giving them to abstractions, we only have the following possibilities: - - no aproj_borrows, in which case the symbolic value was either dropped - or is in the context - - exactly one aproj_borrows over a non-shared value - - potentially several aproj_borrows over shared values - - The result contains the ids of the abstractions in which the projectors were - found, as well as the projection types used in those abstractions. -*) -type looked_up_aproj_borrows = - | NonSharedProj of V.AbstractionId.id * T.rty - | SharedProjs of (V.AbstractionId.id * T.rty) list - -(** Lookup the aproj_borrows (including aproj_shared_borrows) over a - symbolic value which intersect a given set of regions. - - [lookup_shared]: if [true] also explore projectors over shared values, - otherwise ignore. - - This is a helper function. -*) -let lookup_intersecting_aproj_borrows_opt (lookup_shared : bool) - (regions : T.RegionId.Set.t) (sv : V.symbolic_value) (ctx : C.eval_ctx) : - looked_up_aproj_borrows option = - let found : looked_up_aproj_borrows option ref = ref None in - let set_non_shared ((id, ty) : V.AbstractionId.id * T.rty) : unit = - match !found with - | None -> found := Some (NonSharedProj (id, ty)) - | Some _ -> failwith "Unreachable" - in - let add_shared (x : V.AbstractionId.id * T.rty) : unit = - match !found with - | None -> found := Some (SharedProjs [ x ]) - | Some (SharedProjs pl) -> found := Some (SharedProjs (x :: pl)) - | Some (NonSharedProj _) -> failwith "Unreachable" - in - let check_add_proj_borrows (is_shared : bool) abs sv' proj_ty = - if - proj_borrows_intersects_proj_loans - (abs.V.regions, sv', proj_ty) - (regions, sv) - then - let x = (abs.abs_id, proj_ty) in - if is_shared then add_shared x else set_non_shared x - else () - in - let obj = - object - inherit [_] C.iter_eval_ctx as super - method! visit_abs _ abs = super#visit_abs (Some abs) abs - - method! visit_abstract_shared_borrows abs asb = - (* Sanity check *) - (match !found with - | Some (NonSharedProj _) -> failwith "Unreachable" - | _ -> ()); - (* Explore *) - if lookup_shared then - let abs = Option.get abs in - let check asb = - match asb with - | V.AsbBorrow _ -> () - | V.AsbProjReborrows (sv', proj_ty) -> - let is_shared = true in - check_add_proj_borrows is_shared abs sv' proj_ty - in - List.iter check asb - else () - - method! visit_aproj abs sproj = - (let abs = Option.get abs in - match sproj with - | AProjLoans _ | AEndedProjLoans _ | AEndedProjBorrows _ - | AIgnoredProjBorrows -> - () - | AProjBorrows (sv', proj_rty) -> - let is_shared = false in - check_add_proj_borrows is_shared abs sv' proj_rty); - super#visit_aproj abs sproj - end - in - (* Visit *) - obj#visit_eval_ctx None ctx; - (* Return *) - !found - -(** Lookup the aproj_borrows (not aproj_borrows_shared!) over a symbolic - value which intersects a given set of regions. - - Note that there should be **at most one** (one reason is that we force - the expansion of primitively copyable values before giving them to - abstractions). - - Returns the id of the owning abstraction, and the projection type used in - this abstraction. -*) -let lookup_intersecting_aproj_borrows_not_shared_opt - (regions : T.RegionId.Set.t) (sv : V.symbolic_value) (ctx : C.eval_ctx) : - (V.AbstractionId.id * T.rty) option = - let lookup_shared = false in - match lookup_intersecting_aproj_borrows_opt lookup_shared regions sv ctx with - | None -> None - | Some (NonSharedProj (abs_id, rty)) -> Some (abs_id, rty) - | _ -> failwith "Unexpected" - -(** Similar to {!lookup_intersecting_aproj_borrows_opt}, but updates the - values. - - This is a helper function: it might break invariants. - *) -let update_intersecting_aproj_borrows (can_update_shared : bool) - (update_shared : V.AbstractionId.id -> T.rty -> V.abstract_shared_borrows) - (update_non_shared : V.AbstractionId.id -> T.rty -> V.aproj) - (regions : T.RegionId.Set.t) (sv : V.symbolic_value) (ctx : C.eval_ctx) : - C.eval_ctx = - (* Small helpers for sanity checks *) - let shared = ref None in - let add_shared () = - match !shared with None -> shared := Some true | Some b -> assert b - in - let set_non_shared () = - match !shared with - | None -> shared := Some false - | Some _ -> failwith "Found unexpected intersecting proj_borrows" - in - let check_proj_borrows is_shared abs sv' proj_ty = - if - proj_borrows_intersects_proj_loans - (abs.V.regions, sv', proj_ty) - (regions, sv) - then ( - if is_shared then add_shared () else set_non_shared (); - true) - else false - in - (* The visitor *) - let obj = - object - inherit [_] C.map_eval_ctx as super - method! visit_abs _ abs = super#visit_abs (Some abs) abs - - method! visit_abstract_shared_borrows abs asb = - (* Sanity check *) - (match !shared with Some b -> assert b | _ -> ()); - (* Explore *) - if can_update_shared then - let abs = Option.get abs in - let update (asb : V.abstract_shared_borrow) : - V.abstract_shared_borrows = - match asb with - | V.AsbBorrow _ -> [ asb ] - | V.AsbProjReborrows (sv', proj_ty) -> - let is_shared = true in - if check_proj_borrows is_shared abs sv' proj_ty then - update_shared abs.abs_id proj_ty - else [ asb ] - in - List.concat (List.map update asb) - else asb - - method! visit_aproj abs sproj = - match sproj with - | AProjLoans _ | AEndedProjLoans _ | AEndedProjBorrows _ - | AIgnoredProjBorrows -> - super#visit_aproj abs sproj - | AProjBorrows (sv', proj_rty) -> - let abs = Option.get abs in - let is_shared = true in - if check_proj_borrows is_shared abs sv' proj_rty then - update_non_shared abs.abs_id proj_rty - else super#visit_aproj (Some abs) sproj - end - in - (* Apply *) - let ctx = obj#visit_eval_ctx None ctx in - (* Check that we updated the context at least once *) - assert (Option.is_some !shared); - (* Return *) - ctx - -(** Simply calls {!update_intersecting_aproj_borrows} to update a - proj_borrows over a non-shared value. - - We check that we update *at least* one proj_borrows. - - This is a helper function: it might break invariants. - *) -let update_intersecting_aproj_borrows_non_shared (regions : T.RegionId.Set.t) - (sv : V.symbolic_value) (nv : V.aproj) (ctx : C.eval_ctx) : C.eval_ctx = - (* Small helpers *) - let can_update_shared = false in - let update_shared _ _ = failwith "Unexpected" in - let updated = ref false in - let update_non_shared _ _ = - (* We can update more than one borrow! *) - updated := true; - nv - in - (* Update *) - let ctx = - update_intersecting_aproj_borrows can_update_shared update_shared - update_non_shared regions sv ctx - in - (* Check that we updated at least once *) - assert !updated; - (* Return *) - ctx - -(** Simply calls {!update_intersecting_aproj_borrows} to remove the - proj_borrows over shared values. - - This is a helper function: it might break invariants. - *) -let remove_intersecting_aproj_borrows_shared (regions : T.RegionId.Set.t) - (sv : V.symbolic_value) (ctx : C.eval_ctx) : C.eval_ctx = - (* Small helpers *) - let can_update_shared = true in - let update_shared _ _ = [] in - let update_non_shared _ _ = failwith "Unexpected" in - (* Update *) - update_intersecting_aproj_borrows can_update_shared update_shared - update_non_shared regions sv ctx - -(** Updates the proj_loans intersecting some projection. - - This is a helper function: it might break invariants. - - Note that we can update more than one projector of loans! Consider the - following example: - {[ - fn f<'a, 'b>(...) -> (&'a mut u32, &'b mut u32)); - fn g<'c>(&'c mut u32, &'c mut u32); - - let p = f(...); - g(move p); - - // Symbolic context after the call to g: - // abs'a {'a} { [s@0 <: (&'a mut u32, &'b mut u32)] } - // abs'b {'b} { [s@0 <: (&'a mut u32, &'b mut u32)] } - // - // abs'c {'c} { (s@0 <: (&'c mut u32, &'c mut u32)) } - ]} - - Note that for sanity, this function checks that we update *at least* one - projector of loans. - - [subst]: takes as parameters the abstraction in which we perform the - substitution and the list of given back values at the projector of - loans where we perform the substitution (see the fields in {!V.AProjLoans}). - Note that the symbolic value at this place is necessarily equal to [sv], - which is why we don't give it as parameters. - *) -let update_intersecting_aproj_loans (proj_regions : T.RegionId.Set.t) - (proj_ty : T.rty) (sv : V.symbolic_value) - (subst : V.abs -> (V.msymbolic_value * V.aproj) list -> V.aproj) - (ctx : C.eval_ctx) : C.eval_ctx = - (* Small helpers for sanity checks *) - let updated = ref false in - let update abs local_given_back : V.aproj = - (* Note that we can update more than once! *) - updated := true; - subst abs local_given_back - in - (* The visitor *) - let obj = - object - inherit [_] C.map_eval_ctx as super - method! visit_abs _ abs = super#visit_abs (Some abs) abs - - method! visit_aproj abs sproj = - match sproj with - | AProjBorrows _ | AEndedProjLoans _ | AEndedProjBorrows _ - | AIgnoredProjBorrows -> - super#visit_aproj abs sproj - | AProjLoans (sv', given_back) -> - let abs = Option.get abs in - if same_symbolic_id sv sv' then ( - assert (sv.sv_ty = sv'.sv_ty); - if - projections_intersect proj_ty proj_regions sv'.V.sv_ty - abs.regions - then update abs given_back - else super#visit_aproj (Some abs) sproj) - else super#visit_aproj (Some abs) sproj - end - in - (* Apply *) - let ctx = obj#visit_eval_ctx None ctx in - (* Check that we updated the context at least once *) - assert !updated; - (* Return *) - ctx - -(** Helper function: lookup an {!V.AProjLoans} by using an abstraction id and a - symbolic value. - - We return the information from the looked up projector of loans. See the - fields in {!V.AProjLoans} (we don't return the symbolic value, because it - is equal to [sv]). - - Sanity check: we check that there is exactly one projector which corresponds - to the couple (abstraction id, symbolic value). - *) -let lookup_aproj_loans (abs_id : V.AbstractionId.id) (sv : V.symbolic_value) - (ctx : C.eval_ctx) : (V.msymbolic_value * V.aproj) list = - (* Small helpers for sanity checks *) - let found = ref None in - let set_found x = - (* There is at most one projector which corresponds to the description *) - assert (Option.is_none !found); - found := Some x - in - (* The visitor *) - let obj = - object - inherit [_] C.iter_eval_ctx as super - - method! visit_abs _ abs = - if abs.abs_id = abs_id then super#visit_abs (Some abs) abs else () - - method! visit_aproj (abs : V.abs option) sproj = - (match sproj with - | AProjBorrows _ | AEndedProjLoans _ | AEndedProjBorrows _ - | AIgnoredProjBorrows -> - super#visit_aproj abs sproj - | AProjLoans (sv', given_back) -> - let abs = Option.get abs in - assert (abs.abs_id = abs_id); - if sv'.sv_id = sv.sv_id then ( - assert (sv' = sv); - set_found given_back) - else ()); - super#visit_aproj abs sproj - end - in - (* Apply *) - obj#visit_eval_ctx None ctx; - (* Return *) - Option.get !found - -(** Helper function: might break invariants. - - Update a projector over loans. The projector is identified by a symbolic - value and an abstraction id. - - Sanity check: we check that there is exactly one projector which corresponds - to the couple (abstraction id, symbolic value). - *) -let update_aproj_loans (abs_id : V.AbstractionId.id) (sv : V.symbolic_value) - (nproj : V.aproj) (ctx : C.eval_ctx) : C.eval_ctx = - (* Small helpers for sanity checks *) - let found = ref false in - let update () = - (* We update at most once *) - assert (not !found); - found := true; - nproj - in - (* The visitor *) - let obj = - object - inherit [_] C.map_eval_ctx as super - - method! visit_abs _ abs = - if abs.abs_id = abs_id then super#visit_abs (Some abs) abs else abs - - method! visit_aproj (abs : V.abs option) sproj = - match sproj with - | AProjBorrows _ | AEndedProjLoans _ | AEndedProjBorrows _ - | AIgnoredProjBorrows -> - super#visit_aproj abs sproj - | AProjLoans (sv', _) -> - let abs = Option.get abs in - assert (abs.abs_id = abs_id); - if sv'.sv_id = sv.sv_id then ( - assert (sv' = sv); - update ()) - else super#visit_aproj (Some abs) sproj - end - in - (* Apply *) - let ctx = obj#visit_eval_ctx None ctx in - (* Sanity check *) - assert !found; - (* Return *) - ctx - -(** Helper function: might break invariants. - - Update a projector over borrows. The projector is identified by a symbolic - value and an abstraction id. - - Sanity check: we check that there is exactly one projector which corresponds - to the couple (abstraction id, symbolic value). - - TODO: factorize with {!update_aproj_loans}? - *) -let update_aproj_borrows (abs_id : V.AbstractionId.id) (sv : V.symbolic_value) - (nproj : V.aproj) (ctx : C.eval_ctx) : C.eval_ctx = - (* Small helpers for sanity checks *) - let found = ref false in - let update () = - (* We update at most once *) - assert (not !found); - found := true; - nproj - in - (* The visitor *) - let obj = - object - inherit [_] C.map_eval_ctx as super - - method! visit_abs _ abs = - if abs.abs_id = abs_id then super#visit_abs (Some abs) abs else abs - - method! visit_aproj (abs : V.abs option) sproj = - match sproj with - | AProjLoans _ | AEndedProjLoans _ | AEndedProjBorrows _ - | AIgnoredProjBorrows -> - super#visit_aproj abs sproj - | AProjBorrows (sv', _proj_ty) -> - let abs = Option.get abs in - assert (abs.abs_id = abs_id); - if sv'.sv_id = sv.sv_id then ( - assert (sv' = sv); - update ()) - else super#visit_aproj (Some abs) sproj - end - in - (* Apply *) - let ctx = obj#visit_eval_ctx None ctx in - (* Sanity check *) - assert !found; - (* Return *) - ctx - -(** Helper function: might break invariants. - - Converts an {!V.AProjLoans} to an {!V.AEndedProjLoans}. The projector is identified - by a symbolic value and an abstraction id. - *) -let update_aproj_loans_to_ended (abs_id : V.AbstractionId.id) - (sv : V.symbolic_value) (ctx : C.eval_ctx) : C.eval_ctx = - (* Lookup the projector of loans *) - let given_back = lookup_aproj_loans abs_id sv ctx in - (* Create the new value for the projector *) - let nproj = V.AEndedProjLoans (sv, given_back) in - (* Insert it *) - let ctx = update_aproj_loans abs_id sv nproj ctx in - (* Return *) - ctx - -let no_aproj_over_symbolic_in_context (sv : V.symbolic_value) (ctx : C.eval_ctx) - : unit = - (* The visitor *) - let obj = - object - inherit [_] C.iter_eval_ctx as super - - method! visit_aproj env sproj = - (match sproj with - | AEndedProjLoans _ | AEndedProjBorrows _ | AIgnoredProjBorrows -> () - | AProjLoans (sv', _) | AProjBorrows (sv', _) -> - if sv'.sv_id = sv.sv_id then raise Found else ()); - super#visit_aproj env sproj - end - in - (* Apply *) - try obj#visit_eval_ctx () ctx - with Found -> failwith "update_aproj_loans_to_ended: failed" - -(** Helper function - - Return the loan (aloan, loan, proj_loans over a symbolic value) we find - in an abstraction, if there is. - - **Remark:** we don't take the *ignored* mut/shared loans into account. - *) -let get_first_non_ignored_aloan_in_abstraction (abs : V.abs) : - borrow_ids_or_symbolic_value option = - (* Explore to find a loan *) - let obj = - object - inherit [_] V.iter_abs as super - - method! visit_aloan_content env lc = - match lc with - | V.AMutLoan (bid, _) -> raise (FoundBorrowIds (Borrow bid)) - | V.ASharedLoan (bids, _, _) -> raise (FoundBorrowIds (Borrows bids)) - | V.AEndedMutLoan { given_back = _; child = _; given_back_meta = _ } - | V.AEndedSharedLoan (_, _) -> - super#visit_aloan_content env lc - | V.AIgnoredMutLoan (_, _) -> - (* Ignore *) - super#visit_aloan_content env lc - | V.AEndedIgnoredMutLoan - { given_back = _; child = _; given_back_meta = _ } - | V.AIgnoredSharedLoan _ -> - (* Ignore *) - super#visit_aloan_content env lc - - (** We may need to visit loan contents because of shared values *) - method! visit_loan_content _ lc = - match lc with - | V.MutLoan _ -> - (* The mut loan linked to the mutable borrow present in a shared - * value in an abstraction should be in an AProjBorrows *) - failwith "Unreachable" - | V.SharedLoan (bids, _) -> raise (FoundBorrowIds (Borrows bids)) - - method! visit_aproj env sproj = - (match sproj with - | V.AProjBorrows (_, _) - | V.AEndedProjLoans _ | V.AEndedProjBorrows _ | V.AIgnoredProjBorrows -> - () - | V.AProjLoans (sv, _) -> raise (ValuesUtils.FoundSymbolicValue sv)); - super#visit_aproj env sproj - end - in - try - (* Check if there are loans *) - obj#visit_abs () abs; - (* No loans *) - None - with - (* There are loans *) - | FoundBorrowIds bids -> Some (BorrowIds bids) - | ValuesUtils.FoundSymbolicValue sv -> - (* There are loan projections over symbolic values *) - Some (SymbolicValue sv) diff --git a/src/InterpreterExpansion.ml b/src/InterpreterExpansion.ml deleted file mode 100644 index 0ca34b43..00000000 --- a/src/InterpreterExpansion.ml +++ /dev/null @@ -1,733 +0,0 @@ -(* This module provides the functions which handle expansion of symbolic values. - * For now, this file doesn't handle expansion of ⊥ values because they need - * some path utilities for replacement. We might change that in the future (by - * using indices to identify the values for instance). *) - -module T = Types -module V = Values -module E = Expressions -module C = Contexts -module Subst = Substitute -module L = Logging -open TypesUtils -module Inv = Invariants -module S = SynthesizeSymbolic -module SA = SymbolicAst -open Cps -open ValuesUtils -open InterpreterUtils -open InterpreterProjectors -open InterpreterBorrows - -(** The local logger *) -let log = L.expansion_log - -(** Projector kind *) -type proj_kind = LoanProj | BorrowProj - -(** Auxiliary function. - Apply a symbolic expansion to avalues in a context, targetting a specific - kind of projectors. - - [proj_kind] controls whether we apply the expansion to projectors - on loans or projectors on borrows. - - When dealing with reference expansion, it is necessary to first apply the - expansion on loan projectors, then on borrow projectors. The reason is - that reducing the borrow projectors might require to perform some reborrows, - in which case we need to lookup the corresponding loans in the context. - - [allow_reborrows] controls whether we allow reborrows or not. It is useful - only if we target borrow projectors. - - Also, if this function is called on an expansion for *shared references*, - the proj borrows should already have been expanded. - - TODO: the way this function is used is a bit complex, especially because of - the above condition. Maybe we should have: - 1. a generic function to expand the loan projectors - 2. a function to expand the borrow projectors for non-borrows - 3. specialized functions for mut borrows and shared borrows - Note that 2. and 3. may have a little bit of duplicated code, but hopefully - it would make things clearer. -*) -let apply_symbolic_expansion_to_target_avalues (config : C.config) - (allow_reborrows : bool) (proj_kind : proj_kind) - (original_sv : V.symbolic_value) (expansion : V.symbolic_expansion) - (ctx : C.eval_ctx) : C.eval_ctx = - (* Symbolic values contained in the expansion might contain already ended regions *) - let check_symbolic_no_ended = false in - (* Prepare reborrows registration *) - let fresh_reborrow, apply_registered_reborrows = - prepare_reborrows config allow_reborrows - in - (* Visitor to apply the expansion *) - let obj = - object (self) - inherit [_] C.map_eval_ctx as super - - (** When visiting an abstraction, we remember the regions it owns to be - able to properly reduce projectors when expanding symbolic values *) - method! visit_abs current_abs abs = - assert (Option.is_none current_abs); - let current_abs = Some abs in - super#visit_abs current_abs abs - - (** We carefully updated {!visit_ASymbolic} so that {!visit_aproj} is called - only on child projections (i.e., projections which appear in {!AEndedProjLoans}). - The role of visit_aproj is then to check we don't have to expand symbolic - values in child projections, because it should never happen - *) - method! visit_aproj current_abs aproj = - (match aproj with - | AProjLoans (sv, _) | AProjBorrows (sv, _) -> - assert (not (same_symbolic_id sv original_sv)) - | AEndedProjLoans _ | AEndedProjBorrows _ | AIgnoredProjBorrows -> ()); - super#visit_aproj current_abs aproj - - method! visit_ASymbolic current_abs aproj = - let current_abs = Option.get current_abs in - let proj_regions = current_abs.regions in - let ancestors_regions = current_abs.ancestors_regions in - (* Explore in depth first - we won't update anything: we simply - * want to check we don't have to expand inner symbolic value *) - match (aproj, proj_kind) with - | V.AEndedProjBorrows _, _ -> V.ASymbolic aproj - | V.AEndedProjLoans _, _ -> - (* Explore the given back values to make sure we don't have to expand - * anything in there *) - V.ASymbolic (self#visit_aproj (Some current_abs) aproj) - | V.AProjLoans (sv, given_back), LoanProj -> - (* Check if this is the symbolic value we are looking for *) - if same_symbolic_id sv original_sv then ( - (* There mustn't be any given back values *) - assert (given_back = []); - (* Apply the projector *) - let projected_value = - apply_proj_loans_on_symbolic_expansion proj_regions expansion - original_sv.V.sv_ty - in - (* Replace *) - projected_value.V.value) - else - (* Not the searched symbolic value: nothing to do *) - super#visit_ASymbolic (Some current_abs) aproj - | V.AProjBorrows (sv, proj_ty), BorrowProj -> - (* Check if this is the symbolic value we are looking for *) - if same_symbolic_id sv original_sv then - (* Convert the symbolic expansion to a value on which we can - * apply a projector (if the expansion is a reference expansion, - * convert it to a borrow) *) - (* WARNING: we mustn't get there if the expansion is for a shared - * reference. *) - let expansion = - symbolic_expansion_non_shared_borrow_to_value original_sv - expansion - in - (* Apply the projector *) - let projected_value = - apply_proj_borrows check_symbolic_no_ended ctx fresh_reborrow - proj_regions ancestors_regions expansion proj_ty - in - (* Replace *) - projected_value.V.value - else - (* Not the searched symbolic value: nothing to do *) - super#visit_ASymbolic (Some current_abs) aproj - | V.AProjLoans _, BorrowProj - | V.AProjBorrows (_, _), LoanProj - | V.AIgnoredProjBorrows, _ -> - (* Nothing to do *) - V.ASymbolic aproj - end - in - (* Apply the expansion *) - let ctx = obj#visit_eval_ctx None ctx in - (* Apply the reborrows *) - apply_registered_reborrows ctx - -(** Auxiliary function. - Apply a symbolic expansion to avalues in a context. -*) -let apply_symbolic_expansion_to_avalues (config : C.config) - (allow_reborrows : bool) (original_sv : V.symbolic_value) - (expansion : V.symbolic_expansion) (ctx : C.eval_ctx) : C.eval_ctx = - let apply_expansion proj_kind ctx = - apply_symbolic_expansion_to_target_avalues config allow_reborrows proj_kind - original_sv expansion ctx - in - (* First target the loan projectors, then the borrow projectors *) - let ctx = apply_expansion LoanProj ctx in - let ctx = apply_expansion BorrowProj ctx in - ctx - -(** Auxiliary function. - - Simply replace the symbolic values (*not avalues*) in the context with - a given value. Will break invariants if not used properly. -*) -let replace_symbolic_values (at_most_once : bool) - (original_sv : V.symbolic_value) (nv : V.value) (ctx : C.eval_ctx) : - C.eval_ctx = - (* Count *) - let replaced = ref false in - let replace () = - if at_most_once then assert (not !replaced); - replaced := true; - nv - in - (* Visitor to apply the substitution *) - let obj = - object - inherit [_] C.map_eval_ctx as super - - method! visit_Symbolic env spc = - if same_symbolic_id spc original_sv then replace () - else super#visit_Symbolic env spc - end - in - (* Apply the substitution *) - let ctx = obj#visit_eval_ctx None ctx in - (* Return *) - ctx - -(** Apply a symbolic expansion to a context, by replacing the original - symbolic value with its expanded value. Is valid only if the expansion - is not a borrow (i.e., an adt...). - - This function does update the synthesis. -*) -let apply_symbolic_expansion_non_borrow (config : C.config) - (original_sv : V.symbolic_value) (expansion : V.symbolic_expansion) - (ctx : C.eval_ctx) : C.eval_ctx = - (* Apply the expansion to non-abstraction values *) - let nv = symbolic_expansion_non_borrow_to_value original_sv expansion in - let at_most_once = false in - let ctx = replace_symbolic_values at_most_once original_sv nv.V.value ctx in - (* Apply the expansion to abstraction values *) - let allow_reborrows = false in - apply_symbolic_expansion_to_avalues config allow_reborrows original_sv - expansion ctx - -(** Compute the expansion of an adt value. - - The function might return a list of values if the symbolic value to expand - is an enumeration. - - [expand_enumerations] controls the expansion of enumerations: if false, it - doesn't allow the expansion of enumerations *containing several variants*. - *) -let compute_expanded_symbolic_adt_value (expand_enumerations : bool) - (kind : V.sv_kind) (def_id : T.TypeDeclId.id) - (regions : T.RegionId.id T.region list) (types : T.rty list) - (ctx : C.eval_ctx) : V.symbolic_expansion list = - (* Lookup the definition and check if it is an enumeration with several - * variants *) - let def = C.ctx_lookup_type_decl ctx def_id in - assert (List.length regions = List.length def.T.region_params); - (* Retrieve, for every variant, the list of its instantiated field types *) - let variants_fields_types = - Subst.type_decl_get_instantiated_variants_fields_rtypes def regions types - in - (* Check if there is strictly more than one variant *) - if List.length variants_fields_types > 1 && not expand_enumerations then - raise (Failure "Not allowed to expand enumerations with several variants"); - (* Initialize the expanded value for a given variant *) - let initialize - ((variant_id, field_types) : T.VariantId.id option * T.rty list) : - V.symbolic_expansion = - let field_values = - List.map (fun (ty : T.rty) -> mk_fresh_symbolic_value kind ty) field_types - in - let see = V.SeAdt (variant_id, field_values) in - see - in - (* Initialize all the expanded values of all the variants *) - List.map initialize variants_fields_types - -(** Compute the expansion of an Option value. - *) -let compute_expanded_symbolic_option_value (expand_enumerations : bool) - (kind : V.sv_kind) (ty : T.rty) : V.symbolic_expansion list = - assert expand_enumerations; - let some_se = - V.SeAdt (Some T.option_some_id, [ mk_fresh_symbolic_value kind ty ]) - in - let none_se = V.SeAdt (Some T.option_none_id, []) in - [ none_se; some_se ] - -let compute_expanded_symbolic_tuple_value (kind : V.sv_kind) - (field_types : T.rty list) : V.symbolic_expansion = - (* Generate the field values *) - let field_values = - List.map (fun sv_ty -> mk_fresh_symbolic_value kind sv_ty) field_types - in - let variant_id = None in - let see = V.SeAdt (variant_id, field_values) in - see - -let compute_expanded_symbolic_box_value (kind : V.sv_kind) (boxed_ty : T.rty) : - V.symbolic_expansion = - (* Introduce a fresh symbolic value *) - let boxed_value = mk_fresh_symbolic_value kind boxed_ty in - let see = V.SeAdt (None, [ boxed_value ]) in - see - -let expand_symbolic_value_shared_borrow (config : C.config) - (original_sv : V.symbolic_value) (original_sv_place : SA.mplace option) - (ref_ty : T.rty) : cm_fun = - fun cf ctx -> - (* First, replace the projectors on borrows. - * The important point is that the symbolic value to expand may appear - * several times, if it has been copied. In this case, we need to introduce - * one fresh borrow id per instance. - *) - let borrows = ref V.BorrowId.Set.empty in - let fresh_borrow () = - let bid' = C.fresh_borrow_id () in - borrows := V.BorrowId.Set.add bid' !borrows; - bid' - in - (* Small utility used on shared borrows in abstractions (regular borrow - * projector and asb). - * Returns [Some] if the symbolic value has been expanded to an asb list, - * [None] otherwise *) - let reborrow_ashared proj_regions (sv : V.symbolic_value) (proj_ty : T.rty) : - V.abstract_shared_borrows option = - if same_symbolic_id sv original_sv then - match proj_ty with - | T.Ref (r, ref_ty, T.Shared) -> - (* Projector over the shared value *) - let shared_asb = V.AsbProjReborrows (sv, ref_ty) in - (* Check if the region is in the set of projected regions *) - if region_in_set r proj_regions then - (* In the set: we need to reborrow *) - let bid = fresh_borrow () in - Some [ V.AsbBorrow bid; shared_asb ] - else (* Not in the set: ignore *) - Some [ shared_asb ] - | _ -> raise (Failure "Unexpected") - else None - in - (* The fresh symbolic value for the shared value *) - let shared_sv = mk_fresh_symbolic_value original_sv.sv_kind ref_ty in - (* Visitor to replace the projectors on borrows *) - let obj = - object (self) - inherit [_] C.map_eval_ctx as super - - method! visit_Symbolic env sv = - if same_symbolic_id sv original_sv then - let bid = fresh_borrow () in - V.Borrow - (V.SharedBorrow (mk_typed_value_from_symbolic_value shared_sv, bid)) - else super#visit_Symbolic env sv - - method! visit_Abs proj_regions abs = - assert (Option.is_none proj_regions); - let proj_regions = Some abs.V.regions in - super#visit_Abs proj_regions abs - - method! visit_AProjSharedBorrow proj_regions asb = - let expand_asb (asb : V.abstract_shared_borrow) : - V.abstract_shared_borrows = - match asb with - | V.AsbBorrow _ -> [ asb ] - | V.AsbProjReborrows (sv, proj_ty) -> ( - match reborrow_ashared (Option.get proj_regions) sv proj_ty with - | None -> [ asb ] - | Some asb -> asb) - in - let asb = List.concat (List.map expand_asb asb) in - V.AProjSharedBorrow asb - - (** We carefully updated {!visit_ASymbolic} so that {!visit_aproj} is called - only on child projections (i.e., projections which appear in {!AEndedProjLoans}). - The role of visit_aproj is then to check we don't have to expand symbolic - values in child projections, because it should never happen - *) - method! visit_aproj proj_regions aproj = - (match aproj with - | AProjLoans (sv, _) | AProjBorrows (sv, _) -> - assert (not (same_symbolic_id sv original_sv)) - | AEndedProjLoans _ | AEndedProjBorrows _ | AIgnoredProjBorrows -> ()); - super#visit_aproj proj_regions aproj - - method! visit_ASymbolic proj_regions aproj = - match aproj with - | AEndedProjBorrows _ | AIgnoredProjBorrows -> - (* We ignore borrows *) V.ASymbolic aproj - | AProjLoans _ -> - (* Loans are handled later *) - V.ASymbolic aproj - | AProjBorrows (sv, proj_ty) -> ( - (* Check if we need to reborrow *) - match reborrow_ashared (Option.get proj_regions) sv proj_ty with - | None -> super#visit_ASymbolic proj_regions aproj - | Some asb -> V.ABorrow (V.AProjSharedBorrow asb)) - | AEndedProjLoans _ -> - (* Sanity check: make sure there is nothing to expand inside the - * children projections *) - V.ASymbolic (self#visit_aproj proj_regions aproj) - end - in - (* Call the visitor *) - let ctx = obj#visit_eval_ctx None ctx in - (* Finally, replace the projectors on loans *) - let bids = !borrows in - assert (not (V.BorrowId.Set.is_empty bids)); - let see = V.SeSharedRef (bids, shared_sv) in - let allow_reborrows = true in - let ctx = - apply_symbolic_expansion_to_avalues config allow_reborrows original_sv see - ctx - in - (* Call the continuation *) - let expr = cf ctx in - (* Update the synthesized program *) - S.synthesize_symbolic_expansion_no_branching original_sv original_sv_place see - expr - -(** TODO: simplify and merge with the other expansion function *) -let expand_symbolic_value_borrow (config : C.config) - (original_sv : V.symbolic_value) (original_sv_place : SA.mplace option) - (region : T.RegionId.id T.region) (ref_ty : T.rty) (rkind : T.ref_kind) : - cm_fun = - fun cf ctx -> - (* Check that we are allowed to expand the reference *) - assert (not (region_in_set region ctx.ended_regions)); - (* Match on the reference kind *) - match rkind with - | T.Mut -> - (* Simple case: simply create a fresh symbolic value and a fresh - * borrow id *) - let sv = mk_fresh_symbolic_value original_sv.sv_kind ref_ty in - let bid = C.fresh_borrow_id () in - let see = V.SeMutRef (bid, sv) in - (* Expand the symbolic values - we simply perform a substitution (and - * check that we perform exactly one substitution) *) - let nv = symbolic_expansion_non_shared_borrow_to_value original_sv see in - let at_most_once = true in - let ctx = - replace_symbolic_values at_most_once original_sv nv.V.value ctx - in - (* Expand the symbolic avalues *) - let allow_reborrows = true in - let ctx = - apply_symbolic_expansion_to_avalues config allow_reborrows original_sv - see ctx - in - (* Apply the continuation *) - let expr = cf ctx in - (* Update the synthesized program *) - S.synthesize_symbolic_expansion_no_branching original_sv original_sv_place - see expr - | T.Shared -> - expand_symbolic_value_shared_borrow config original_sv original_sv_place - ref_ty cf ctx - -(** A small helper. - - Apply a branching symbolic expansion to a context and execute all the - branches. Note that the expansion is optional for every branch (this is - used for integer expansion: see [expand_symbolic_int]). - - [see_cf_l]: list of pairs (optional symbolic expansion, continuation) -*) -let apply_branching_symbolic_expansions_non_borrow (config : C.config) - (sv : V.symbolic_value) (sv_place : SA.mplace option) - (see_cf_l : (V.symbolic_expansion option * m_fun) list) : m_fun = - fun ctx -> - assert (see_cf_l <> []); - (* Apply the symbolic expansion in in the context and call the continuation *) - let resl = - List.map - (fun (see_opt, cf) -> - (* Expansion *) - let ctx = - match see_opt with - | None -> ctx - | Some see -> apply_symbolic_expansion_non_borrow config sv see ctx - in - (* Continuation *) - cf ctx) - see_cf_l - in - (* Collect the result: either we computed no subterm, or we computed all - * of them *) - let subterms = - match resl with - | Some _ :: _ -> Some (List.map Option.get resl) - | None :: _ -> - List.iter (fun res -> assert (res = None)) resl; - None - | _ -> raise (Failure "Unreachable") - in - (* Synthesize and return *) - let seel = List.map fst see_cf_l in - S.synthesize_symbolic_expansion sv sv_place seel subterms - -(** Expand a symbolic boolean *) -let expand_symbolic_bool (config : C.config) (sp : V.symbolic_value) - (sp_place : SA.mplace option) (cf_true : m_fun) (cf_false : m_fun) : m_fun = - fun ctx -> - (* Compute the expanded value *) - let original_sv = sp in - let original_sv_place = sp_place in - let rty = original_sv.V.sv_ty in - assert (rty = T.Bool); - (* Expand the symbolic value to true or false and continue execution *) - let see_true = V.SeConcrete (V.Bool true) in - let see_false = V.SeConcrete (V.Bool false) in - let seel = [ (Some see_true, cf_true); (Some see_false, cf_false) ] in - (* Apply the symbolic expansion (this also outputs the updated symbolic AST) *) - apply_branching_symbolic_expansions_non_borrow config original_sv - original_sv_place seel ctx - -(** Expand a symbolic value. - - [allow_branching]: if [true] we can branch (by expanding enumerations with - stricly more than one variant), otherwise we can't. - - TODO: rename [sp] to [sv] - *) -let expand_symbolic_value (config : C.config) (allow_branching : bool) - (sp : V.symbolic_value) (sp_place : SA.mplace option) : cm_fun = - fun cf ctx -> - (* Debug *) - log#ldebug (lazy ("expand_symbolic_value:" ^ symbolic_value_to_string ctx sp)); - (* Remember the initial context for printing purposes *) - let ctx0 = ctx in - (* Compute the expanded value - note that when doing so, we may introduce - * fresh symbolic values in the context (which thus gets updated) *) - let original_sv = sp in - let original_sv_place = sp_place in - let rty = original_sv.V.sv_ty in - let cc : cm_fun = - fun cf ctx -> - match rty with - (* TODO: I think it is possible to factorize a lot the below match *) - (* "Regular" ADTs *) - | T.Adt (T.AdtId def_id, regions, types) -> - (* Compute the expanded value *) - let seel = - compute_expanded_symbolic_adt_value allow_branching sp.sv_kind def_id - regions types ctx - in - (* Check for branching *) - assert (List.length seel <= 1 || allow_branching); - (* Apply *) - let seel = List.map (fun see -> (Some see, cf)) seel in - apply_branching_symbolic_expansions_non_borrow config original_sv - original_sv_place seel ctx - (* Options *) - | T.Adt (T.Assumed Option, regions, types) -> - (* Sanity check *) - assert (regions = []); - let ty = Collections.List.to_cons_nil types in - (* Compute the expanded value *) - let seel = - compute_expanded_symbolic_option_value allow_branching sp.sv_kind ty - in - - (* Check for branching *) - assert (List.length seel <= 1 || allow_branching); - (* Apply *) - let seel = List.map (fun see -> (Some see, cf)) seel in - apply_branching_symbolic_expansions_non_borrow config original_sv - original_sv_place seel ctx - (* Tuples *) - | T.Adt (T.Tuple, [], tys) -> - (* Generate the field values *) - let see = compute_expanded_symbolic_tuple_value sp.sv_kind tys in - (* Apply in the context *) - let ctx = - apply_symbolic_expansion_non_borrow config original_sv see ctx - in - (* Call the continuation *) - let expr = cf ctx in - (* Update the synthesized program *) - S.synthesize_symbolic_expansion_no_branching original_sv - original_sv_place see expr - (* Boxes *) - | T.Adt (T.Assumed T.Box, [], [ boxed_ty ]) -> - let see = compute_expanded_symbolic_box_value sp.sv_kind boxed_ty in - (* Apply in the context *) - let ctx = - apply_symbolic_expansion_non_borrow config original_sv see ctx - in - (* Call the continuation *) - let expr = cf ctx in - (* Update the synthesized program *) - S.synthesize_symbolic_expansion_no_branching original_sv - original_sv_place see expr - (* Borrows *) - | T.Ref (region, ref_ty, rkind) -> - expand_symbolic_value_borrow config original_sv original_sv_place region - ref_ty rkind cf ctx - (* Booleans *) - | T.Bool -> - assert allow_branching; - expand_symbolic_bool config sp sp_place cf cf ctx - | _ -> - raise - (Failure ("expand_symbolic_value: unexpected type: " ^ T.show_rty rty)) - in - (* Debug *) - let cc = - comp_unit cc (fun ctx -> - log#ldebug - (lazy - ("expand_symbolic_value: " - ^ symbolic_value_to_string ctx0 sp - ^ "\n\n- original context:\n" ^ eval_ctx_to_string ctx0 - ^ "\n\n- new context:\n" ^ eval_ctx_to_string ctx ^ "\n")); - (* Sanity check: the symbolic value has disappeared *) - assert (not (symbolic_value_id_in_ctx original_sv.V.sv_id ctx))) - in - (* Continue *) - cc cf ctx - -(** Symbolic integers are expanded upon evaluating a [switch], when the integer - is not an enumeration discriminant. - Note that a discriminant is never symbolic: we evaluate discriminant values - upon evaluating [eval_discriminant], which always generates a concrete value - (because if we call it on a symbolic enumeration, we expand the enumeration - *then* evaluate the discriminant). This is how we can spot "regular" switches - over integers. - - - When expanding a boolean upon evaluating an [if ... then ... else ...], - or an enumeration just before matching over it, we can simply expand the - boolean/enumeration (generating a list of contexts from which to execute) - then retry evaluating the [if ... then ... else ...] or the [match]: as - the scrutinee will then have a concrete value, the interpreter will switch - to the proper branch. - - However, when expanding a "regular" integer for a switch, there is always an - *otherwise* branch that we can take, for which the integer must remain symbolic - (because in this branch the scrutinee can take a range of values). We thus - can't simply expand then retry to evaluate the [switch], because then we - would loop... - - For this reason, we take the list of branches to execute as parameters, and - directly jump to those branches after the expansion, without reevaluating the - switch. The continuation is thus for the execution *after* the switch. -*) -let expand_symbolic_int (config : C.config) (sv : V.symbolic_value) - (sv_place : SA.mplace option) (int_type : T.integer_type) - (tgts : (V.scalar_value * m_fun) list) (otherwise : m_fun) : m_fun = - (* Sanity check *) - assert (sv.V.sv_ty = T.Integer int_type); - (* For all the branches of the switch, we expand the symbolic value - * to the value given by the branch and execute the branch statement. - * For the otherwise branch, we leave the symbolic value as it is - * (because this branch doesn't precisely define which should be the - * value of the scrutinee...) and simply execute the otherwise statement. - * - * First, generate the list of pairs: - * (optional expansion, statement to execute) - *) - let tgts = - List.map (fun (v, cf) -> (Some (V.SeConcrete (V.Scalar v)), cf)) tgts - in - let tgts = List.append tgts [ (None, otherwise) ] in - (* Then expand and evaluate - this generates the proper symbolic AST *) - apply_branching_symbolic_expansions_non_borrow config sv sv_place tgts - -(** See [expand_symbolic_value] *) -let expand_symbolic_value_no_branching (config : C.config) - (sv : V.symbolic_value) (sv_place : SA.mplace option) : cm_fun = - let allow_branching = false in - expand_symbolic_value config allow_branching sv sv_place - -(** Expand all the symbolic values which contain borrows. - Allows us to restrict ourselves to a simpler model for the projectors over - symbolic values. - - Fails if doing this requires to do a branching (because we need to expand - an enumeration with strictly more than one variant, a slice, etc.) or if - we need to expand a recursive type (because this leads to looping). - *) -let greedy_expand_symbolics_with_borrows (config : C.config) : cm_fun = - fun cf ctx -> - (* The visitor object, to look for symbolic values in the concrete environment *) - let obj = - object - inherit [_] C.iter_eval_ctx - - method! visit_Symbolic _ sv = - if ty_has_borrows ctx.type_context.type_infos sv.V.sv_ty then - raise (FoundSymbolicValue sv) - else () - - (** Don't enter abstractions *) - method! visit_abs _ _ = () - end - in - - let rec expand : cm_fun = - fun cf ctx -> - try - obj#visit_eval_ctx () ctx; - (* Nothing to expand: continue *) - cf ctx - with FoundSymbolicValue sv -> - (* Expand and recheck the environment *) - log#ldebug - (lazy - ("greedy_expand_symbolics_with_borrows: about to expand: " - ^ symbolic_value_to_string ctx sv)); - let cc : cm_fun = - match sv.V.sv_ty with - | T.Adt (AdtId def_id, _, _) -> - (* {!expand_symbolic_value_no_branching} checks if there are branchings, - * but we prefer to also check it here - this leads to cleaner messages - * and debugging *) - let def = C.ctx_lookup_type_decl ctx def_id in - (match def.kind with - | T.Struct _ | T.Enum ([] | [ _ ]) -> () - | T.Enum (_ :: _) -> - raise - (Failure - ("Attempted to greedily expand a symbolic enumeration \ - with > 1 variants (option \ - [greedy_expand_symbolics_with_borrows] of [config]): " - ^ Print.name_to_string def.name)) - | T.Opaque -> - raise (Failure "Attempted to greedily expand an opaque type")); - (* Also, we need to check if the definition is recursive *) - if C.ctx_type_decl_is_rec ctx def_id then - raise - (Failure - ("Attempted to greedily expand a recursive definition \ - (option [greedy_expand_symbolics_with_borrows] of \ - [config]): " - ^ Print.name_to_string def.name)) - else expand_symbolic_value_no_branching config sv None - | T.Adt ((Tuple | Assumed Box), _, _) | T.Ref (_, _, _) -> - (* Ok *) - expand_symbolic_value_no_branching config sv None - | T.Adt (Assumed (Vec | Option), _, _) -> - (* We can't expand those *) - raise (Failure "Attempted to greedily expand a Vec or an Option ") - | T.Array _ -> raise Errors.Unimplemented - | T.Slice _ -> raise (Failure "Can't expand symbolic slices") - | T.TypeVar _ | Bool | Char | Never | Integer _ | Str -> - raise (Failure "Unreachable") - in - (* Compose and continue *) - comp cc expand cf ctx - in - (* Apply *) - expand cf ctx - -(** If this mode is activated through the [config], greedily expand the symbolic - values which need to be expanded. See [config] for more information. - *) -let greedy_expand_symbolic_values (config : C.config) : cm_fun = - fun cf ctx -> - if config.greedy_expand_symbolics_with_borrows then ( - log#ldebug (lazy "greedy_expand_symbolic_values"); - greedy_expand_symbolics_with_borrows config cf ctx) - else cf ctx diff --git a/src/InterpreterExpressions.ml b/src/InterpreterExpressions.ml deleted file mode 100644 index 62d9b80b..00000000 --- a/src/InterpreterExpressions.ml +++ /dev/null @@ -1,720 +0,0 @@ -module T = Types -module V = Values -module LA = LlbcAst -open Scalars -module E = Expressions -open Errors -module C = Contexts -module Subst = Substitute -module L = Logging -module PV = Print.Values -open TypesUtils -open ValuesUtils -module Inv = Invariants -module S = SynthesizeSymbolic -open Cps -open InterpreterUtils -open InterpreterExpansion -open InterpreterPaths - -(** The local logger *) -let log = L.expressions_log - -(** As long as there are symbolic values at a given place (potentially in subvalues) - which contain borrows and are primitively copyable, expand them. - - We use this function before copying values. - - Note that the place should have been prepared so that there are no remaining - loans. -*) -let expand_primitively_copyable_at_place (config : C.config) - (access : access_kind) (p : E.place) : cm_fun = - fun cf ctx -> - (* Small helper *) - let rec expand : cm_fun = - fun cf ctx -> - let v = read_place_unwrap config access p ctx in - match - find_first_primitively_copyable_sv_with_borrows - ctx.type_context.type_infos v - with - | None -> cf ctx - | Some sv -> - let cc = - expand_symbolic_value_no_branching config sv - (Some (S.mk_mplace p ctx)) - in - comp cc expand cf ctx - in - (* Apply *) - expand cf ctx - -(** Read a place (CPS-style function). - - We also check that the value *doesn't contain bottoms or inactivated - borrows. - *) -let read_place (config : C.config) (access : access_kind) (p : E.place) - (cf : V.typed_value -> m_fun) : m_fun = - fun ctx -> - let v = read_place_unwrap config access p ctx in - (* Check that there are no bottoms in the value *) - assert (not (bottom_in_value ctx.ended_regions v)); - (* Check that there are no inactivated borrows in the value *) - assert (not (inactivated_in_value v)); - (* Call the continuation *) - cf v ctx - -(** Small utility. - - Prepare the access to a place in a right-value (typically an operand) by - reorganizing the environment. - - We reorganize the environment so that: - - we can access the place (we prepare *along* the path) - - the value at the place itself doesn't contain loans (the [access_kind] - controls whether we only end mutable loans, or also shared loans). - - We also check, after the reorganization, that the value at the place - *doesn't contain any bottom nor inactivated borrows*. - - [expand_prim_copy]: if true, expand the symbolic values which are primitively - copyable and contain borrows. - *) -let access_rplace_reorganize_and_read (config : C.config) - (expand_prim_copy : bool) (access : access_kind) (p : E.place) - (cf : V.typed_value -> m_fun) : m_fun = - fun ctx -> - (* Make sure we can evaluate the path *) - let cc = update_ctx_along_read_place config access p in - (* End the proper loans at the place itself *) - let cc = comp cc (end_loans_at_place config access p) in - (* Expand the copyable values which contain borrows (which are necessarily shared - * borrows) *) - let cc = - if expand_prim_copy then - comp cc (expand_primitively_copyable_at_place config access p) - else cc - in - (* Read the place - note that this checks that the value doesn't contain bottoms *) - let read_place = read_place config access p in - (* Compose *) - comp cc read_place cf ctx - -let access_rplace_reorganize (config : C.config) (expand_prim_copy : bool) - (access : access_kind) (p : E.place) : cm_fun = - fun cf ctx -> - access_rplace_reorganize_and_read config expand_prim_copy access p - (fun _v -> cf) - ctx - -(** Convert an operand constant operand value to a typed value *) -let constant_to_typed_value (ty : T.ety) (cv : V.constant_value) : V.typed_value - = - (* Check the type while converting - we actually need some information - * contained in the type *) - log#ldebug - (lazy - ("constant_to_typed_value:" ^ "\n- cv: " ^ PV.constant_value_to_string cv)); - match (ty, cv) with - (* Scalar, boolean... *) - | T.Bool, Bool v -> { V.value = V.Concrete (Bool v); ty } - | T.Char, Char v -> { V.value = V.Concrete (Char v); ty } - | T.Str, String v -> { V.value = V.Concrete (String v); ty } - | T.Integer int_ty, V.Scalar v -> - (* Check the type and the ranges *) - assert (int_ty = v.int_ty); - assert (check_scalar_value_in_range v); - { V.value = V.Concrete (V.Scalar v); ty } - (* Remaining cases (invalid) *) - | _, _ -> failwith "Improperly typed constant value" - -(** Reorganize the environment in preparation for the evaluation of an operand. - - Evaluating an operand requires reorganizing the environment to get access - to a given place (by ending borrows, expanding symbolic values...) then - applying the operand operation (move, copy, etc.). - - Sometimes, we want to decouple the two operations. - Consider the following example: - {[ - context = { - x -> shared_borrow l0 - y -> shared_loan {l0} v - } - - dest <- f(move x, move y); - ... - ]} - Because of the way [end_borrow] is implemented, when giving back the borrow - [l0] upon evaluating [move y], we won't notice that [shared_borrow l0] has - disappeared from the environment (it has been moved and not assigned yet, - and so is hanging in "thin air"). - - By first "preparing" the operands evaluation, we make sure no such thing - happens. To be more precise, we make sure all the updates to borrows triggered - by access *and* move operations have already been applied. - - Rk.: in the formalization, we always have an explicit "reorganization" step - in the rule premises, before the actual operand evaluation. - - Rk.: doing this is actually not completely necessary because when - generating MIR, rustc introduces intermediate assignments for all the function - parameters. Still, it is better for soundness purposes, and corresponds to - what we do in the formalization (because we don't enforce constraints - in the formalization). - *) -let prepare_eval_operand_reorganize (config : C.config) (op : E.operand) : - cm_fun = - fun cf ctx -> - let prepare : cm_fun = - fun cf ctx -> - match op with - | Expressions.Constant (ty, cv) -> - (* No need to reorganize the context *) - constant_to_typed_value ty cv |> ignore; - cf ctx - | Expressions.Copy p -> - (* Access the value *) - let access = Read in - (* Expand the symbolic values, if necessary *) - let expand_prim_copy = true in - access_rplace_reorganize config expand_prim_copy access p cf ctx - | Expressions.Move p -> - (* Access the value *) - let access = Move in - let expand_prim_copy = false in - access_rplace_reorganize config expand_prim_copy access p cf ctx - in - (* Apply *) - prepare cf ctx - -(** Evaluate an operand, without reorganizing the context before *) -let eval_operand_no_reorganize (config : C.config) (op : E.operand) - (cf : V.typed_value -> m_fun) : m_fun = - fun ctx -> - (* Debug *) - log#ldebug - (lazy - ("eval_operand_no_reorganize: op: " ^ operand_to_string ctx op - ^ "\n- ctx:\n" ^ eval_ctx_to_string ctx ^ "\n")); - (* Evaluate *) - match op with - | Expressions.Constant (ty, cv) -> cf (constant_to_typed_value ty cv) ctx - | Expressions.Copy p -> - (* Access the value *) - let access = Read in - let cc = read_place config access p in - (* Copy the value *) - let copy cf v : m_fun = - fun ctx -> - (* Sanity checks *) - assert (not (bottom_in_value ctx.ended_regions v)); - assert ( - Option.is_none - (find_first_primitively_copyable_sv_with_borrows - ctx.type_context.type_infos v)); - (* Actually perform the copy *) - let allow_adt_copy = false in - let ctx, v = copy_value allow_adt_copy config ctx v in - (* Continue *) - cf v ctx - in - (* Compose and apply *) - comp cc copy cf ctx - | Expressions.Move p -> - (* Access the value *) - let access = Move in - let cc = read_place config access p in - (* Move the value *) - let move cf v : m_fun = - fun ctx -> - (* Check that there are no bottoms in the value we are about to move *) - assert (not (bottom_in_value ctx.ended_regions v)); - let bottom : V.typed_value = { V.value = Bottom; ty = v.ty } in - match write_place config access p bottom ctx with - | Error _ -> failwith "Unreachable" - | Ok ctx -> cf v ctx - in - (* Compose and apply *) - comp cc move cf ctx - -(** Evaluate an operand. - - Reorganize the context, then evaluate the operand. - - **Warning**: this function shouldn't be used to evaluate a list of - operands (for a function call, for instance): we must do *one* reorganization - of the environment, before evaluating all the operands at once. - Use [eval_operands] instead. - *) -let eval_operand (config : C.config) (op : E.operand) - (cf : V.typed_value -> m_fun) : m_fun = - fun ctx -> - (* Debug *) - log#ldebug - (lazy - ("eval_operand: op: " ^ operand_to_string ctx op ^ "\n- ctx:\n" - ^ eval_ctx_to_string ctx ^ "\n")); - (* We reorganize the context, then evaluate the operand *) - comp - (prepare_eval_operand_reorganize config op) - (eval_operand_no_reorganize config op) - cf ctx - -(** Small utility. - - See [prepare_eval_operand_reorganize]. - *) -let prepare_eval_operands_reorganize (config : C.config) (ops : E.operand list) - : cm_fun = - fold_left_apply_continuation (prepare_eval_operand_reorganize config) ops - -(** Evaluate several operands. *) -let eval_operands (config : C.config) (ops : E.operand list) - (cf : V.typed_value list -> m_fun) : m_fun = - fun ctx -> - (* Prepare the operands *) - let prepare = prepare_eval_operands_reorganize config ops in - (* Evaluate the operands *) - let eval = - fold_left_list_apply_continuation (eval_operand_no_reorganize config) ops - in - (* Compose and apply *) - comp prepare eval cf ctx - -let eval_two_operands (config : C.config) (op1 : E.operand) (op2 : E.operand) - (cf : V.typed_value * V.typed_value -> m_fun) : m_fun = - let eval_op = eval_operands config [ op1; op2 ] in - let use_res cf res = - match res with [ v1; v2 ] -> cf (v1, v2) | _ -> failwith "Unreachable" - in - comp eval_op use_res cf - -let eval_unary_op_concrete (config : C.config) (unop : E.unop) (op : E.operand) - (cf : (V.typed_value, eval_error) result -> m_fun) : m_fun = - (* Evaluate the operand *) - let eval_op = eval_operand config op in - (* Apply the unop *) - let apply cf (v : V.typed_value) : m_fun = - match (unop, v.V.value) with - | E.Not, V.Concrete (Bool b) -> - cf (Ok { v with V.value = V.Concrete (Bool (not b)) }) - | E.Neg, V.Concrete (V.Scalar sv) -> ( - let i = Z.neg sv.V.value in - match mk_scalar sv.int_ty i with - | Error _ -> cf (Error EPanic) - | Ok sv -> cf (Ok { v with V.value = V.Concrete (V.Scalar sv) })) - | E.Cast (src_ty, tgt_ty), V.Concrete (V.Scalar sv) -> ( - assert (src_ty == sv.int_ty); - let i = sv.V.value in - match mk_scalar tgt_ty i with - | Error _ -> cf (Error EPanic) - | Ok sv -> - let ty = T.Integer tgt_ty in - let value = V.Concrete (V.Scalar sv) in - cf (Ok { V.ty; value })) - | _ -> raise (Failure "Invalid input for unop") - in - comp eval_op apply cf - -let eval_unary_op_symbolic (config : C.config) (unop : E.unop) (op : E.operand) - (cf : (V.typed_value, eval_error) result -> m_fun) : m_fun = - fun ctx -> - (* Evaluate the operand *) - let eval_op = eval_operand config op in - (* Generate a fresh symbolic value to store the result *) - let apply cf (v : V.typed_value) : m_fun = - fun ctx -> - let res_sv_id = C.fresh_symbolic_value_id () in - let res_sv_ty = - match (unop, v.V.ty) with - | E.Not, T.Bool -> T.Bool - | E.Neg, T.Integer int_ty -> T.Integer int_ty - | E.Cast (_, tgt_ty), _ -> T.Integer tgt_ty - | _ -> raise (Failure "Invalid input for unop") - in - let res_sv = - { V.sv_kind = V.FunCallRet; V.sv_id = res_sv_id; sv_ty = res_sv_ty } - in - (* Call the continuation *) - let expr = cf (Ok (mk_typed_value_from_symbolic_value res_sv)) ctx in - (* Synthesize the symbolic AST *) - S.synthesize_unary_op unop v - (S.mk_opt_place_from_op op ctx) - res_sv None expr - in - (* Compose and apply *) - comp eval_op apply cf ctx - -let eval_unary_op (config : C.config) (unop : E.unop) (op : E.operand) - (cf : (V.typed_value, eval_error) result -> m_fun) : m_fun = - match config.mode with - | C.ConcreteMode -> eval_unary_op_concrete config unop op cf - | C.SymbolicMode -> eval_unary_op_symbolic config unop op cf - -(** Small helper for [eval_binary_op_concrete]: computes the result of applying - the binop *after* the operands have been successfully evaluated - *) -let eval_binary_op_concrete_compute (binop : E.binop) (v1 : V.typed_value) - (v2 : V.typed_value) : (V.typed_value, eval_error) result = - (* Equality check binops (Eq, Ne) accept values from a wide variety of types. - * The remaining binops only operate on scalars. *) - if binop = Eq || binop = Ne then ( - (* Equality operations *) - assert (v1.ty = v2.ty); - (* Equality/inequality check is primitive only for a subset of types *) - assert (ty_is_primitively_copyable v1.ty); - let b = v1 = v2 in - Ok { V.value = V.Concrete (Bool b); ty = T.Bool }) - else - (* For the non-equality operations, the input values are necessarily scalars *) - match (v1.V.value, v2.V.value) with - | V.Concrete (V.Scalar sv1), V.Concrete (V.Scalar sv2) -> ( - (* There are binops which require the two operands to have the same - type, and binops for which it is not the case. - There are also binops which return booleans, and binops which - return integers. - *) - match binop with - | E.Lt | E.Le | E.Ge | E.Gt -> - (* The two operands must have the same type and the result is a boolean *) - assert (sv1.int_ty = sv2.int_ty); - let b = - match binop with - | E.Lt -> Z.lt sv1.V.value sv2.V.value - | E.Le -> Z.leq sv1.V.value sv2.V.value - | E.Ge -> Z.geq sv1.V.value sv2.V.value - | E.Gt -> Z.gt sv1.V.value sv2.V.value - | E.Div | E.Rem | E.Add | E.Sub | E.Mul | E.BitXor | E.BitAnd - | E.BitOr | E.Shl | E.Shr | E.Ne | E.Eq -> - raise (Failure "Unreachable") - in - Ok ({ V.value = V.Concrete (Bool b); ty = T.Bool } : V.typed_value) - | E.Div | E.Rem | E.Add | E.Sub | E.Mul | E.BitXor | E.BitAnd | E.BitOr - -> ( - (* The two operands must have the same type and the result is an integer *) - assert (sv1.int_ty = sv2.int_ty); - let res = - match binop with - | E.Div -> - if sv2.V.value = Z.zero then Error () - else mk_scalar sv1.int_ty (Z.div sv1.V.value sv2.V.value) - | E.Rem -> - (* See [https://github.com/ocaml/Zarith/blob/master/z.mli] *) - if sv2.V.value = Z.zero then Error () - else mk_scalar sv1.int_ty (Z.rem sv1.V.value sv2.V.value) - | E.Add -> mk_scalar sv1.int_ty (Z.add sv1.V.value sv2.V.value) - | E.Sub -> mk_scalar sv1.int_ty (Z.sub sv1.V.value sv2.V.value) - | E.Mul -> mk_scalar sv1.int_ty (Z.mul sv1.V.value sv2.V.value) - | E.BitXor -> raise Unimplemented - | E.BitAnd -> raise Unimplemented - | E.BitOr -> raise Unimplemented - | E.Lt | E.Le | E.Ge | E.Gt | E.Shl | E.Shr | E.Ne | E.Eq -> - raise (Failure "Unreachable") - in - match res with - | Error _ -> Error EPanic - | Ok sv -> - Ok - { - V.value = V.Concrete (V.Scalar sv); - ty = Integer sv1.int_ty; - }) - | E.Shl | E.Shr -> raise Unimplemented - | E.Ne | E.Eq -> raise (Failure "Unreachable")) - | _ -> raise (Failure "Invalid inputs for binop") - -let eval_binary_op_concrete (config : C.config) (binop : E.binop) - (op1 : E.operand) (op2 : E.operand) - (cf : (V.typed_value, eval_error) result -> m_fun) : m_fun = - (* Evaluate the operands *) - let eval_ops = eval_two_operands config op1 op2 in - (* Compute the result of the binop *) - let compute cf (res : V.typed_value * V.typed_value) = - let v1, v2 = res in - cf (eval_binary_op_concrete_compute binop v1 v2) - in - (* Compose and apply *) - comp eval_ops compute cf - -let eval_binary_op_symbolic (config : C.config) (binop : E.binop) - (op1 : E.operand) (op2 : E.operand) - (cf : (V.typed_value, eval_error) result -> m_fun) : m_fun = - fun ctx -> - (* Evaluate the operands *) - let eval_ops = eval_two_operands config op1 op2 in - (* Compute the result of applying the binop *) - let compute cf ((v1, v2) : V.typed_value * V.typed_value) : m_fun = - fun ctx -> - (* Generate a fresh symbolic value to store the result *) - let res_sv_id = C.fresh_symbolic_value_id () in - let res_sv_ty = - if binop = Eq || binop = Ne then ( - (* Equality operations *) - assert (v1.ty = v2.ty); - (* Equality/inequality check is primitive only for a subset of types *) - assert (ty_is_primitively_copyable v1.ty); - T.Bool) - else - (* Other operations: input types are integers *) - match (v1.V.ty, v2.V.ty) with - | T.Integer int_ty1, T.Integer int_ty2 -> ( - match binop with - | E.Lt | E.Le | E.Ge | E.Gt -> - assert (int_ty1 = int_ty2); - T.Bool - | E.Div | E.Rem | E.Add | E.Sub | E.Mul | E.BitXor | E.BitAnd - | E.BitOr -> - assert (int_ty1 = int_ty2); - T.Integer int_ty1 - | E.Shl | E.Shr -> raise Unimplemented - | E.Ne | E.Eq -> raise (Failure "Unreachable")) - | _ -> raise (Failure "Invalid inputs for binop") - in - let res_sv = - { V.sv_kind = V.FunCallRet; V.sv_id = res_sv_id; sv_ty = res_sv_ty } - in - (* Call the continuattion *) - let v = mk_typed_value_from_symbolic_value res_sv in - let expr = cf (Ok v) ctx in - (* Synthesize the symbolic AST *) - let p1 = S.mk_opt_place_from_op op1 ctx in - let p2 = S.mk_opt_place_from_op op2 ctx in - S.synthesize_binary_op binop v1 p1 v2 p2 res_sv None expr - in - (* Compose and apply *) - comp eval_ops compute cf ctx - -let eval_binary_op (config : C.config) (binop : E.binop) (op1 : E.operand) - (op2 : E.operand) (cf : (V.typed_value, eval_error) result -> m_fun) : m_fun - = - match config.mode with - | C.ConcreteMode -> eval_binary_op_concrete config binop op1 op2 cf - | C.SymbolicMode -> eval_binary_op_symbolic config binop op1 op2 cf - -(** Evaluate the discriminant of a concrete (i.e., non symbolic) ADT value *) -let eval_rvalue_discriminant_concrete (config : C.config) (p : E.place) - (cf : V.typed_value -> m_fun) : m_fun = - (* Note that discriminant values have type [isize] *) - (* Access the value *) - let access = Read in - let expand_prim_copy = false in - let prepare = - access_rplace_reorganize_and_read config expand_prim_copy access p - in - (* Read the value *) - let read (cf : V.typed_value -> m_fun) (v : V.typed_value) : m_fun = - (* The value may be shared: we need to ignore the shared loans *) - let v = value_strip_shared_loans v in - match v.V.value with - | Adt av -> ( - match av.variant_id with - | None -> - raise - (Failure - "Invalid input for `discriminant`: structure instead of enum") - | Some variant_id -> ( - let id = Z.of_int (T.VariantId.to_int variant_id) in - match mk_scalar Isize id with - | Error _ -> raise (Failure "Disciminant id out of range") - (* Should really never happen *) - | Ok sv -> - cf { V.value = V.Concrete (V.Scalar sv); ty = Integer Isize })) - | _ -> - raise - (Failure ("Invalid input for `discriminant`: " ^ V.show_typed_value v)) - in - (* Compose and apply *) - comp prepare read cf - -(** Evaluate the discriminant of an ADT value. - - Might lead to branching, if the value is symbolic. - *) -let eval_rvalue_discriminant (config : C.config) (p : E.place) - (cf : V.typed_value -> m_fun) : m_fun = - fun ctx -> - log#ldebug (lazy "eval_rvalue_discriminant"); - (* Note that discriminant values have type [isize] *) - (* Access the value *) - let access = Read in - let expand_prim_copy = false in - let prepare = - access_rplace_reorganize_and_read config expand_prim_copy access p - in - (* Read the value *) - let read (cf : V.typed_value -> m_fun) (v : V.typed_value) : m_fun = - fun ctx -> - (* The value may be shared: we need to ignore the shared loans *) - let v = value_strip_shared_loans v in - match v.V.value with - | Adt _ -> eval_rvalue_discriminant_concrete config p cf ctx - | Symbolic sv -> - (* Expand the symbolic value - may lead to branching *) - let allow_branching = true in - let cc = - expand_symbolic_value config allow_branching sv - (Some (S.mk_mplace p ctx)) - in - (* This time the value is concrete: reevaluate *) - comp cc (eval_rvalue_discriminant_concrete config p) cf ctx - | _ -> - raise - (Failure ("Invalid input for `discriminant`: " ^ V.show_typed_value v)) - in - (* Compose and apply *) - comp prepare read cf ctx - -let eval_rvalue_ref (config : C.config) (p : E.place) (bkind : E.borrow_kind) - (cf : V.typed_value -> m_fun) : m_fun = - fun ctx -> - match bkind with - | E.Shared | E.TwoPhaseMut -> - (* Access the value *) - let access = if bkind = E.Shared then Read else Write in - let expand_prim_copy = false in - let prepare = - access_rplace_reorganize_and_read config expand_prim_copy access p - in - (* Evaluate the borrowing operation *) - let eval (cf : V.typed_value -> m_fun) (v : V.typed_value) : m_fun = - fun ctx -> - (* Generate the fresh borrow id *) - let bid = C.fresh_borrow_id () in - (* Compute the loan value, with which to replace the value at place p *) - let nv, shared_mvalue = - match v.V.value with - | V.Loan (V.SharedLoan (bids, sv)) -> - (* Shared loan: insert the new borrow id *) - let bids1 = V.BorrowId.Set.add bid bids in - ({ v with V.value = V.Loan (V.SharedLoan (bids1, sv)) }, sv) - | _ -> - (* Not a shared loan: add a wrapper *) - let v' = - V.Loan (V.SharedLoan (V.BorrowId.Set.singleton bid, v)) - in - ({ v with V.value = v' }, v) - in - (* Update the borrowed value in the context *) - let ctx = write_place_unwrap config access p nv ctx in - (* Compute the rvalue - simply a shared borrow with a the fresh id. - * Note that the reference is *mutable* if we do a two-phase borrow *) - let rv_ty = - T.Ref (T.Erased, v.ty, if bkind = E.Shared then Shared else Mut) - in - let bc = - if bkind = E.Shared then V.SharedBorrow (shared_mvalue, bid) - else V.InactivatedMutBorrow (shared_mvalue, bid) - in - let rv : V.typed_value = { V.value = V.Borrow bc; ty = rv_ty } in - (* Continue *) - cf rv ctx - in - (* Compose and apply *) - comp prepare eval cf ctx - | E.Mut -> - (* Access the value *) - let access = Write in - let expand_prim_copy = false in - let prepare = - access_rplace_reorganize_and_read config expand_prim_copy access p - in - (* Evaluate the borrowing operation *) - let eval (cf : V.typed_value -> m_fun) (v : V.typed_value) : m_fun = - fun ctx -> - (* Compute the rvalue - wrap the value in a mutable borrow with a fresh id *) - let bid = C.fresh_borrow_id () in - let rv_ty = T.Ref (T.Erased, v.ty, Mut) in - let rv : V.typed_value = - { V.value = V.Borrow (V.MutBorrow (bid, v)); ty = rv_ty } - in - (* Compute the value with which to replace the value at place p *) - let nv = { v with V.value = V.Loan (V.MutLoan bid) } in - (* Update the value in the context *) - let ctx = write_place_unwrap config access p nv ctx in - (* Continue *) - cf rv ctx - in - (* Compose and apply *) - comp prepare eval cf ctx - -let eval_rvalue_aggregate (config : C.config) - (aggregate_kind : E.aggregate_kind) (ops : E.operand list) - (cf : V.typed_value -> m_fun) : m_fun = - (* Evaluate the operands *) - let eval_ops = eval_operands config ops in - (* Compute the value *) - let compute (cf : V.typed_value -> m_fun) (values : V.typed_value list) : - m_fun = - fun ctx -> - (* Match on the aggregate kind *) - match aggregate_kind with - | E.AggregatedTuple -> - let tys = List.map (fun (v : V.typed_value) -> v.V.ty) values in - let v = V.Adt { variant_id = None; field_values = values } in - let ty = T.Adt (T.Tuple, [], tys) in - let aggregated : V.typed_value = { V.value = v; ty } in - (* Call the continuation *) - cf aggregated ctx - | E.AggregatedOption (variant_id, ty) -> - (* Sanity check *) - if variant_id == T.option_none_id then assert (values == []) - else if variant_id == T.option_some_id then - assert (List.length values == 1) - else raise (Failure "Unreachable"); - (* Construt the value *) - let aty = T.Adt (T.Assumed T.Option, [], [ ty ]) in - let av : V.adt_value = - { V.variant_id = Some variant_id; V.field_values = values } - in - let aggregated : V.typed_value = { V.value = Adt av; ty = aty } in - (* Call the continuation *) - cf aggregated ctx - | E.AggregatedAdt (def_id, opt_variant_id, regions, types) -> - (* Sanity checks *) - let type_decl = C.ctx_lookup_type_decl ctx def_id in - assert (List.length type_decl.region_params = List.length regions); - let expected_field_types = - Subst.ctx_adt_get_instantiated_field_etypes ctx def_id opt_variant_id - types - in - assert ( - expected_field_types - = List.map (fun (v : V.typed_value) -> v.V.ty) values); - (* Construct the value *) - let av : V.adt_value = - { V.variant_id = opt_variant_id; V.field_values = values } - in - let aty = T.Adt (T.AdtId def_id, regions, types) in - let aggregated : V.typed_value = { V.value = Adt av; ty = aty } in - (* Call the continuation *) - cf aggregated ctx - in - (* Compose and apply *) - comp eval_ops compute cf - -(** Evaluate an rvalue. - - Transmits the computed rvalue to the received continuation. - *) -let eval_rvalue (config : C.config) (rvalue : E.rvalue) - (cf : (V.typed_value, eval_error) result -> m_fun) : m_fun = - fun ctx -> - log#ldebug (lazy "eval_rvalue"); - (* Small helpers *) - let wrap_in_result (cf : (V.typed_value, eval_error) result -> m_fun) - (v : V.typed_value) : m_fun = - cf (Ok v) - in - let comp_wrap f = comp f wrap_in_result cf in - (* Delegate to the proper auxiliary function *) - match rvalue with - | E.Use op -> comp_wrap (eval_operand config op) ctx - | E.Ref (p, bkind) -> comp_wrap (eval_rvalue_ref config p bkind) ctx - | E.UnaryOp (unop, op) -> eval_unary_op config unop op cf ctx - | E.BinaryOp (binop, op1, op2) -> eval_binary_op config binop op1 op2 cf ctx - | E.Aggregate (aggregate_kind, ops) -> - comp_wrap (eval_rvalue_aggregate config aggregate_kind ops) ctx - | E.Discriminant p -> comp_wrap (eval_rvalue_discriminant config p) ctx diff --git a/src/InterpreterPaths.ml b/src/InterpreterPaths.ml deleted file mode 100644 index d54a046e..00000000 --- a/src/InterpreterPaths.ml +++ /dev/null @@ -1,801 +0,0 @@ -module T = Types -module V = Values -module E = Expressions -module C = Contexts -module Subst = Substitute -module L = Logging -open Cps -open TypesUtils -open ValuesUtils -open InterpreterUtils -open InterpreterBorrowsCore -open InterpreterBorrows -open InterpreterExpansion -module Synth = SynthesizeSymbolic - -(** The local logger *) -let log = L.paths_log - -(** Paths *) - -(** When we fail reading from or writing to a path, it might be because we - need to update the environment by ending borrows, expanding symbolic - values, etc. The following type is used to convey this information. - - TODO: compare with borrow_lres? -*) -type path_fail_kind = - | FailSharedLoan of V.BorrowId.Set.t - (** Failure because we couldn't go inside a shared loan *) - | FailMutLoan of V.BorrowId.id - (** Failure because we couldn't go inside a mutable loan *) - | FailInactivatedMutBorrow of V.BorrowId.id - (** Failure because we couldn't go inside an inactivated mutable borrow - (which should get activated) *) - | FailSymbolic of int * V.symbolic_value - (** Failure because we need to enter a symbolic value (and thus need to - expand it). - We return the number of elements which remained in the path when we - reached the error - this allows to retrieve the path prefix, which - is useful for the synthesis. *) - | FailBottom of int * E.projection_elem * T.ety - (** Failure because we need to enter an any value - we can expand Bottom - values if they are left values. We return the number of elements which - remained in the path when we reached the error - this allows to - properly update the Bottom value, if needs be. - *) - | FailBorrow of V.borrow_content - (** We got stuck because we couldn't enter a borrow *) - -(** Result of evaluating a path (reading from a path/writing to a path) - - Note that when we fail, we return information used to update the - environment, as well as the -*) -type 'a path_access_result = ('a, path_fail_kind) result -(** The result of reading from/writing to a place *) - -type updated_read_value = { read : V.typed_value; updated : V.typed_value } - -type projection_access = { - enter_shared_loans : bool; - enter_mut_borrows : bool; - lookup_shared_borrows : bool; -} - -(** Generic function to access (read/write) the value at the end of a projection. - - We return the (eventually) updated value, the value we read at the end of - the place and the (eventually) updated environment. - - TODO: use exceptions? - *) -let rec access_projection (access : projection_access) (ctx : C.eval_ctx) - (* Function to (eventually) update the value we find *) - (update : V.typed_value -> V.typed_value) (p : E.projection) - (v : V.typed_value) : (C.eval_ctx * updated_read_value) path_access_result = - (* For looking up/updating shared loans *) - let ek : exploration_kind = - { enter_shared_loans = true; enter_mut_borrows = true; enter_abs = true } - in - match p with - | [] -> - let nv = update v in - (* Type checking *) - if nv.ty <> v.ty then ( - log#lerror - (lazy - ("Not the same type:\n- nv.ty: " ^ T.show_ety nv.ty ^ "\n- v.ty: " - ^ T.show_ety v.ty)); - failwith - "Assertion failed: new value doesn't have the same type as its \ - destination"); - Ok (ctx, { read = v; updated = nv }) - | pe :: p' -> ( - (* Match on the projection element and the value *) - match (pe, v.V.value, v.V.ty) with - | ( Field (((ProjAdt (_, _) | ProjOption _) as proj_kind), field_id), - V.Adt adt, - T.Adt (type_id, _, _) ) -> ( - (* Check consistency *) - (match (proj_kind, type_id) with - | ProjAdt (def_id, opt_variant_id), T.AdtId def_id' -> - assert (def_id = def_id'); - assert (opt_variant_id = adt.variant_id) - | ProjOption variant_id, T.Assumed T.Option -> - assert (Some variant_id = adt.variant_id) - | _ -> failwith "Unreachable"); - (* Actually project *) - let fv = T.FieldId.nth adt.field_values field_id in - match access_projection access ctx update p' fv with - | Error err -> Error err - | Ok (ctx, res) -> - (* Update the field value *) - let nvalues = - T.FieldId.update_nth adt.field_values field_id res.updated - in - let nadt = V.Adt { adt with V.field_values = nvalues } in - let updated = { v with value = nadt } in - Ok (ctx, { res with updated })) - (* Tuples *) - | Field (ProjTuple arity, field_id), V.Adt adt, T.Adt (T.Tuple, _, _) -> ( - assert (arity = List.length adt.field_values); - let fv = T.FieldId.nth adt.field_values field_id in - (* Project *) - match access_projection access ctx update p' fv with - | Error err -> Error err - | Ok (ctx, res) -> - (* Update the field value *) - let nvalues = - T.FieldId.update_nth adt.field_values field_id res.updated - in - let ntuple = V.Adt { adt with field_values = nvalues } in - let updated = { v with value = ntuple } in - Ok (ctx, { res with updated }) - (* If we reach Bottom, it may mean we need to expand an uninitialized - * enumeration value *)) - | Field ((ProjAdt (_, _) | ProjTuple _ | ProjOption _), _), V.Bottom, _ -> - Error (FailBottom (1 + List.length p', pe, v.ty)) - (* Symbolic value: needs to be expanded *) - | _, Symbolic sp, _ -> - (* Expand the symbolic value *) - Error (FailSymbolic (1 + List.length p', sp)) - (* Box dereferencement *) - | ( DerefBox, - Adt { variant_id = None; field_values = [ bv ] }, - T.Adt (T.Assumed T.Box, _, _) ) -> ( - (* We allow moving inside of boxes. In practice, this kind of - * manipulations should happen only inside unsage code, so - * it shouldn't happen due to user code, and we leverage it - * when implementing box dereferencement for the concrete - * interpreter *) - match access_projection access ctx update p' bv with - | Error err -> Error err - | Ok (ctx, res) -> - let nv = - { - v with - value = - V.Adt { variant_id = None; field_values = [ res.updated ] }; - } - in - Ok (ctx, { res with updated = nv })) - (* Borrows *) - | Deref, V.Borrow bc, _ -> ( - match bc with - | V.SharedBorrow (_, bid) -> - (* Lookup the loan content, and explore from there *) - if access.lookup_shared_borrows then - match lookup_loan ek bid ctx with - | _, Concrete (V.MutLoan _) -> failwith "Expected a shared loan" - | _, Concrete (V.SharedLoan (bids, sv)) -> ( - (* Explore the shared value *) - match access_projection access ctx update p' sv with - | Error err -> Error err - | Ok (ctx, res) -> - (* Update the shared loan with the new value returned - by {!access_projection} *) - let ctx = - update_loan ek bid - (V.SharedLoan (bids, res.updated)) - ctx - in - (* Return - note that we don't need to update the borrow itself *) - Ok (ctx, { res with updated = v })) - | ( _, - Abstract - ( V.AMutLoan (_, _) - | V.AEndedMutLoan - { given_back = _; child = _; given_back_meta = _ } - | V.AEndedSharedLoan (_, _) - | V.AIgnoredMutLoan (_, _) - | V.AEndedIgnoredMutLoan - { given_back = _; child = _; given_back_meta = _ } - | V.AIgnoredSharedLoan _ ) ) -> - failwith "Expected a shared (abstraction) loan" - | _, Abstract (V.ASharedLoan (bids, sv, _av)) -> ( - (* Explore the shared value *) - match access_projection access ctx update p' sv with - | Error err -> Error err - | Ok (ctx, res) -> - (* Relookup the child avalue *) - let av = - match lookup_loan ek bid ctx with - | _, Abstract (V.ASharedLoan (_, _, av)) -> av - | _ -> failwith "Unexpected" - in - (* Update the shared loan with the new value returned - by {!access_projection} *) - let ctx = - update_aloan ek bid - (V.ASharedLoan (bids, res.updated, av)) - ctx - in - (* Return - note that we don't need to update the borrow itself *) - Ok (ctx, { res with updated = v })) - else Error (FailBorrow bc) - | V.InactivatedMutBorrow (_, bid) -> - Error (FailInactivatedMutBorrow bid) - | V.MutBorrow (bid, bv) -> - if access.enter_mut_borrows then - match access_projection access ctx update p' bv with - | Error err -> Error err - | Ok (ctx, res) -> - let nv = - { - v with - value = V.Borrow (V.MutBorrow (bid, res.updated)); - } - in - Ok (ctx, { res with updated = nv }) - else Error (FailBorrow bc)) - | _, V.Loan lc, _ -> ( - match lc with - | V.MutLoan bid -> Error (FailMutLoan bid) - | V.SharedLoan (bids, sv) -> - (* If we can enter shared loan, we ignore the loan. Pay attention - to the fact that we need to reexplore the *whole* place (i.e, - we mustn't ignore the current projection element *) - if access.enter_shared_loans then - match access_projection access ctx update (pe :: p') sv with - | Error err -> Error err - | Ok (ctx, res) -> - let nv = - { - v with - value = V.Loan (V.SharedLoan (bids, res.updated)); - } - in - Ok (ctx, { res with updated = nv }) - else Error (FailSharedLoan bids)) - | (_, (V.Concrete _ | V.Adt _ | V.Bottom | V.Borrow _), _) as r -> - let pe, v, ty = r in - let pe = "- pe: " ^ E.show_projection_elem pe in - let v = "- v:\n" ^ V.show_value v in - let ty = "- ty:\n" ^ T.show_ety ty in - log#serror ("Inconsistent projection:\n" ^ pe ^ "\n" ^ v ^ "\n" ^ ty); - failwith "Inconsistent projection") - -(** Generic function to access (read/write) the value at a given place. - - We return the value we read at the place and the (eventually) updated - environment, if we managed to access the place, or the precise reason - why we failed. - *) -let access_place (access : projection_access) - (* Function to (eventually) update the value we find *) - (update : V.typed_value -> V.typed_value) (p : E.place) (ctx : C.eval_ctx) - : (C.eval_ctx * V.typed_value) path_access_result = - (* Lookup the variable's value *) - let value = C.ctx_lookup_var_value ctx p.var_id in - (* Apply the projection *) - match access_projection access ctx update p.projection value with - | Error err -> Error err - | Ok (ctx, res) -> - (* Update the value *) - let ctx = C.ctx_update_var_value ctx p.var_id res.updated in - (* Return *) - Ok (ctx, res.read) - -type access_kind = - | Read (** We can go inside borrows and loans *) - | Write (** Don't enter shared borrows or shared loans *) - | Move (** Don't enter borrows or loans *) - -let access_kind_to_projection_access (access : access_kind) : projection_access - = - match access with - | Read -> - { - enter_shared_loans = true; - enter_mut_borrows = true; - lookup_shared_borrows = true; - } - | Write -> - { - enter_shared_loans = false; - enter_mut_borrows = true; - lookup_shared_borrows = false; - } - | Move -> - { - enter_shared_loans = false; - enter_mut_borrows = false; - lookup_shared_borrows = false; - } - -(** Read the value at a given place. - - Note that we only access the value at the place, and do not check that - the value is "well-formed" (for instance that it doesn't contain bottoms). - *) -let read_place (config : C.config) (access : access_kind) (p : E.place) - (ctx : C.eval_ctx) : V.typed_value path_access_result = - let access = access_kind_to_projection_access access in - (* The update function is the identity *) - let update v = v in - match access_place access update p ctx with - | Error err -> Error err - | Ok (ctx1, read_value) -> - (* Note that we ignore the new environment: it should be the same as the - original one. - *) - if config.check_invariants then - if ctx1 <> ctx then ( - let msg = - "Unexpected environment update:\nNew environment:\n" - ^ C.show_env ctx1.env ^ "\n\nOld environment:\n" - ^ C.show_env ctx.env - in - log#serror msg; - failwith "Unexpected environment update"); - Ok read_value - -let read_place_unwrap (config : C.config) (access : access_kind) (p : E.place) - (ctx : C.eval_ctx) : V.typed_value = - match read_place config access p ctx with - | Error _ -> failwith "Unreachable" - | Ok v -> v - -(** Update the value at a given place *) -let write_place (_config : C.config) (access : access_kind) (p : E.place) - (nv : V.typed_value) (ctx : C.eval_ctx) : C.eval_ctx path_access_result = - let access = access_kind_to_projection_access access in - (* The update function substitutes the value with the new value *) - let update _ = nv in - match access_place access update p ctx with - | Error err -> Error err - | Ok (ctx, _) -> - (* We ignore the read value *) - Ok ctx - -let write_place_unwrap (config : C.config) (access : access_kind) (p : E.place) - (nv : V.typed_value) (ctx : C.eval_ctx) : C.eval_ctx = - match write_place config access p nv ctx with - | Error _ -> failwith "Unreachable" - | Ok ctx -> ctx - -(** Compute an expanded ADT bottom value *) -let compute_expanded_bottom_adt_value (tyctx : T.type_decl T.TypeDeclId.Map.t) - (def_id : T.TypeDeclId.id) (opt_variant_id : T.VariantId.id option) - (regions : T.erased_region list) (types : T.ety list) : V.typed_value = - (* Lookup the definition and check if it is an enumeration - it - should be an enumeration if and only if the projection element - is a field projection with *some* variant id. Retrieve the list - of fields at the same time. *) - let def = T.TypeDeclId.Map.find def_id tyctx in - assert (List.length regions = List.length def.T.region_params); - (* Compute the field types *) - let field_types = - Subst.type_decl_get_instantiated_field_etypes def opt_variant_id types - in - (* Initialize the expanded value *) - let fields = List.map mk_bottom field_types in - let av = V.Adt { variant_id = opt_variant_id; field_values = fields } in - let ty = T.Adt (T.AdtId def_id, regions, types) in - { V.value = av; V.ty } - -(** Compute an expanded Option bottom value *) -let compute_expanded_bottom_option_value (variant_id : T.VariantId.id) - (param_ty : T.ety) : V.typed_value = - (* Note that the variant can be [Some] or [None]: we expand bottom values - * when writing to fields or setting discriminants *) - let field_values = - if variant_id = T.option_some_id then [ mk_bottom param_ty ] - else if variant_id = T.option_none_id then [] - else raise (Failure "Unreachable") - in - let av = V.Adt { variant_id = Some variant_id; field_values } in - let ty = T.Adt (T.Assumed T.Option, [], [ param_ty ]) in - { V.value = av; ty } - -(** Compute an expanded tuple bottom value *) -let compute_expanded_bottom_tuple_value (field_types : T.ety list) : - V.typed_value = - (* Generate the field values *) - let fields = List.map mk_bottom field_types in - let v = V.Adt { variant_id = None; field_values = fields } in - let ty = T.Adt (T.Tuple, [], field_types) in - { V.value = v; V.ty } - -(** Auxiliary helper to expand {!V.Bottom} values. - - During compilation, rustc desaggregates the ADT initializations. The - consequence is that the following rust code: - {[ - let x = Cons a b; - ]} - - Looks like this in MIR: - {[ - (x as Cons).0 = a; - (x as Cons).1 = b; - set_discriminant(x, 0); // If [Cons] is the variant of index 0 - ]} - - The consequence is that we may sometimes need to write fields to values - which are currently {!V.Bottom}. When doing this, we first expand the value - to, say, [Cons Bottom Bottom] (note that field projection contains information - about which variant we should project to, which is why we *can* set the - variant index when writing one of its fields). -*) -let expand_bottom_value_from_projection (config : C.config) - (access : access_kind) (p : E.place) (remaining_pes : int) - (pe : E.projection_elem) (ty : T.ety) (ctx : C.eval_ctx) : C.eval_ctx = - (* Debugging *) - log#ldebug - (lazy - ("expand_bottom_value_from_projection:\n" ^ "pe: " - ^ E.show_projection_elem pe ^ "\n" ^ "ty: " ^ T.show_ety ty)); - (* Prepare the update: we need to take the proper prefix of the place - during whose evaluation we got stuck *) - let projection' = - fst - (Collections.List.split_at p.projection - (List.length p.projection - remaining_pes)) - in - let p' = { p with projection = projection' } in - (* Compute the expanded value. - The type of the {!V.Bottom} value should be a tuple or an ADT. - Note that the projection element we got stuck at should be a - field projection, and gives the variant id if the {!V.Bottom} value - is an enumeration value. - Also, the expanded value should be the proper ADT variant or a tuple - with the proper arity, with all the fields initialized to {!V.Bottom} - *) - let nv = - match (pe, ty) with - (* "Regular" ADTs *) - | ( Field (ProjAdt (def_id, opt_variant_id), _), - T.Adt (T.AdtId def_id', regions, types) ) -> - assert (def_id = def_id'); - compute_expanded_bottom_adt_value ctx.type_context.type_decls def_id - opt_variant_id regions types - (* Option *) - | Field (ProjOption variant_id, _), T.Adt (T.Assumed T.Option, [], [ ty ]) - -> - compute_expanded_bottom_option_value variant_id ty - (* Tuples *) - | Field (ProjTuple arity, _), T.Adt (T.Tuple, [], tys) -> - assert (arity = List.length tys); - (* Generate the field values *) - compute_expanded_bottom_tuple_value tys - | _ -> - failwith - ("Unreachable: " ^ E.show_projection_elem pe ^ ", " ^ T.show_ety ty) - in - (* Update the context by inserting the expanded value at the proper place *) - match write_place config access p' nv ctx with - | Ok ctx -> ctx - | Error _ -> failwith "Unreachable" - -(** Update the environment to be able to read a place. - - When reading a place, we may be stuck along the way because some value - is borrowed, we reach a symbolic value, etc. In this situation [read_place] - fails while returning precise information about the failure. This function - uses this information to update the environment (by ending borrows, - expanding symbolic values) until we manage to fully read the place. - *) -let rec update_ctx_along_read_place (config : C.config) (access : access_kind) - (p : E.place) : cm_fun = - fun cf ctx -> - (* Attempt to read the place: if it fails, update the environment and retry *) - match read_place config access p ctx with - | Ok _ -> cf ctx - | Error err -> - let cc = - match err with - | FailSharedLoan bids -> end_outer_borrows config bids - | FailMutLoan bid -> end_outer_borrow config bid - | FailInactivatedMutBorrow bid -> - activate_inactivated_mut_borrow config bid - | FailSymbolic (i, sp) -> - (* Expand the symbolic value *) - let proj, _ = - Collections.List.split_at p.projection - (List.length p.projection - i) - in - let prefix = { p with projection = proj } in - expand_symbolic_value_no_branching config sp - (Some (Synth.mk_mplace prefix ctx)) - | FailBottom (_, _, _) -> - (* We can't expand {!V.Bottom} values while reading them *) - failwith "Found [Bottom] while reading a place" - | FailBorrow _ -> failwith "Could not read a borrow" - in - comp cc (update_ctx_along_read_place config access p) cf ctx - -(** Update the environment to be able to write to a place. - - See {!update_ctx_along_read_place}. -*) -let rec update_ctx_along_write_place (config : C.config) (access : access_kind) - (p : E.place) : cm_fun = - fun cf ctx -> - (* Attempt to *read* (yes, *read*: we check the access to the place, and - write to it later) the place: if it fails, update the environment and retry *) - match read_place config access p ctx with - | Ok _ -> cf ctx - | Error err -> - (* Update the context *) - let cc = - match err with - | FailSharedLoan bids -> end_outer_borrows config bids - | FailMutLoan bid -> end_outer_borrow config bid - | FailInactivatedMutBorrow bid -> - activate_inactivated_mut_borrow config bid - | FailSymbolic (_pe, sp) -> - (* Expand the symbolic value *) - expand_symbolic_value_no_branching config sp - (Some (Synth.mk_mplace p ctx)) - | FailBottom (remaining_pes, pe, ty) -> - (* Expand the {!V.Bottom} value *) - fun cf ctx -> - let ctx = - expand_bottom_value_from_projection config access p remaining_pes - pe ty ctx - in - cf ctx - | FailBorrow _ -> failwith "Could not write to a borrow" - in - (* Retry *) - comp cc (update_ctx_along_write_place config access p) cf ctx - -(** Small utility used to break control-flow *) -exception UpdateCtx of cm_fun - -(** End the loans at a given place: read the value, if it contains a loan, - end this loan, repeat. - - This is used when reading or borrowing values. We typically - first call {!update_ctx_along_read_place} or {!update_ctx_along_write_place} - to get access to the value, then call this function to "prepare" the value: - when moving values, we can't move a value which contains loans and thus need - to end them, etc. - *) -let rec end_loans_at_place (config : C.config) (access : access_kind) - (p : E.place) : cm_fun = - fun cf ctx -> - (* Iterator to explore a value and update the context whenever we find - * loans. - * We use exceptions to make it handy: whenever we update the - * context, we raise an exception wrapping the updated context. - * *) - let obj = - object - inherit [_] V.iter_typed_value as super - - method! visit_borrow_content env bc = - match bc with - | V.SharedBorrow _ | V.MutBorrow (_, _) -> - (* Nothing special to do *) super#visit_borrow_content env bc - | V.InactivatedMutBorrow (_, bid) -> - (* We need to activate inactivated borrows *) - let cc = activate_inactivated_mut_borrow config bid in - raise (UpdateCtx cc) - - method! visit_loan_content env lc = - match lc with - | V.SharedLoan (bids, v) -> ( - (* End the loans if we need a modification access, otherwise dive into - the shared value *) - match access with - | Read -> super#visit_SharedLoan env bids v - | Write | Move -> - let cc = end_outer_borrows config bids in - raise (UpdateCtx cc)) - | V.MutLoan bid -> - (* We always need to end mutable borrows *) - let cc = end_outer_borrow config bid in - raise (UpdateCtx cc) - end - in - - (* First, retrieve the value *) - match read_place config access p ctx with - | Error _ -> failwith "Unreachable" - | Ok v -> ( - (* Inspect the value and update the context while doing so. - If the context gets updated: perform a recursive call (many things - may have been updated in the context: we need to re-read the value - at place [p] - and this value may actually not be accessible - anymore...) - *) - try - obj#visit_typed_value () v; - (* No context update required: apply the continuation *) - cf ctx - with UpdateCtx cc -> - (* We need to update the context: compose the caugth continuation with - * a recursive call to reinspect the value *) - comp cc (end_loans_at_place config access p) cf ctx) - -(** Drop (end) outer loans and borrows at a given place, which should be - seen as an l-value (we will write to it later, but need to drop - the borrows before writing). - - This is used to drop values when evaluating the drop statement or before - writing to a place. - - [end_borrows]: - - if true: end all the loans and borrows we find, starting with the outer - ones. This is used when evaluating the [drop] statement (see [drop_value]) - - if false: only end the outer loans. This is used by [assign_to_place] - or to drop the loans in the local variables when popping a frame. - - Note that we don't do what is defined in the formalization: we move the - value to a temporary dummy value, then explore this value and end the - loans/borrows inside as long as we find some, starting with the outer - ones, then move the resulting value back to where it was. This shouldn't - make any difference, really (note that the place is *inside* a borrow, - if we end the borrow, we won't be able to reinsert the value back). - *) -let drop_outer_borrows_loans_at_lplace (config : C.config) (end_borrows : bool) - (p : E.place) : cm_fun = - fun cf ctx -> - (* Move the current value in the place outside of this place and into - * a dummy variable *) - let access = Write in - let v = read_place_unwrap config access p ctx in - let ctx = write_place_unwrap config access p (mk_bottom v.V.ty) ctx in - let ctx = C.ctx_push_dummy_var ctx v in - (* Auxiliary function *) - let rec drop : cm_fun = - fun cf ctx -> - (* Read the value *) - let v = C.ctx_read_first_dummy_var ctx in - (* Check if there are loans or borrows to end *) - match get_first_outer_loan_or_borrow_in_value end_borrows v with - | None -> - (* We are done: simply call the continuation *) - cf ctx - | Some c -> - (* There are: end them then retry *) - let cc = - match c with - | LoanContent (V.SharedLoan (bids, _)) -> - end_outer_borrows config bids - | LoanContent (V.MutLoan bid) - | BorrowContent (V.MutBorrow (bid, _) | SharedBorrow (_, bid)) -> - end_outer_borrow config bid - | BorrowContent (V.InactivatedMutBorrow (_, bid)) -> - (* First activate the borrow *) - activate_inactivated_mut_borrow config bid - in - (* Retry *) - comp cc drop cf ctx - in - (* Apply the drop function *) - let cc = drop in - (* Pop the temporary value and reinsert it *) - let cc = - comp cc (fun cf ctx -> - (* Pop *) - let ctx, v = C.ctx_pop_dummy_var ctx in - (* Reinsert *) - let ctx = write_place_unwrap config access p v ctx in - (* Sanity check *) - if end_borrows then ( - assert (not (loans_in_value v)); - assert (not (borrows_in_value v))) - else assert (not (outer_loans_in_value v)); - (* Continue *) - cf ctx) - in - (* Continue *) - cc cf ctx - -(** Copy a value, and return the resulting value. - - Note that copying values might update the context. For instance, when - copying shared borrows, we need to insert new shared borrows in the context. - - Also, this function is actually more general than it should be: it can be used - to copy concrete ADT values, while ADT copy should be done through the Copy - trait (i.e., by calling a dedicated function). This is why we added a parameter - to control this copy. Note that here by ADT we mean the user-defined ADTs - (not tuples or assumed types). - - TODO: move - *) -let rec copy_value (allow_adt_copy : bool) (config : C.config) - (ctx : C.eval_ctx) (v : V.typed_value) : C.eval_ctx * V.typed_value = - log#ldebug - (lazy - ("copy_value: " - ^ typed_value_to_string ctx v - ^ "\n- context:\n" ^ eval_ctx_to_string ctx)); - (* Remark: at some point we rewrote this function to use iterators, but then - * we reverted the changes: the result was less clear actually. In particular, - * the fact that we have exhaustive matches below makes very obvious the cases - * in which we need to fail *) - match v.V.value with - | V.Concrete _ -> (ctx, v) - | V.Adt av -> - (* Sanity check *) - (match v.V.ty with - | T.Adt (T.Assumed (T.Box | Vec), _, _) -> - failwith "Can't copy an assumed value other than Option" - | T.Adt (T.AdtId _, _, _) -> assert allow_adt_copy - | T.Adt ((T.Assumed Option | T.Tuple), _, _) -> () (* Ok *) - | _ -> failwith "Unreachable"); - let ctx, fields = - List.fold_left_map - (copy_value allow_adt_copy config) - ctx av.field_values - in - (ctx, { v with V.value = V.Adt { av with field_values = fields } }) - | V.Bottom -> failwith "Can't copy ⊥" - | V.Borrow bc -> ( - (* We can only copy shared borrows *) - match bc with - | SharedBorrow (mv, bid) -> - (* We need to create a new borrow id for the copied borrow, and - * update the context accordingly *) - let bid' = C.fresh_borrow_id () in - let ctx = reborrow_shared bid bid' ctx in - (ctx, { v with V.value = V.Borrow (SharedBorrow (mv, bid')) }) - | MutBorrow (_, _) -> failwith "Can't copy a mutable borrow" - | V.InactivatedMutBorrow _ -> - failwith "Can't copy an inactivated mut borrow") - | V.Loan lc -> ( - (* We can only copy shared loans *) - match lc with - | V.MutLoan _ -> failwith "Can't copy a mutable loan" - | V.SharedLoan (_, sv) -> - (* We don't copy the shared loan: only the shared value inside *) - copy_value allow_adt_copy config ctx sv) - | V.Symbolic sp -> - (* We can copy only if the type is "primitively" copyable. - * Note that in the general case, copy is a trait: copying values - * thus requires calling the proper function. Here, we copy values - * for very simple types such as integers, shared borrows, etc. *) - assert (ty_is_primitively_copyable (Subst.erase_regions sp.V.sv_ty)); - (* If the type is copyable, we simply return the current value. Side - * remark: what is important to look at when copying symbolic values - * is symbolic expansion. The important subcase is the expansion of shared - * borrows: when doing so, every occurrence of the same symbolic value - * must use a fresh borrow id. *) - (ctx, v) - -(** Small utility. - - Prepare a place which is to be used as the destination of an assignment: - update the environment along the paths, end the loans at this place, etc. - - Return the updated context and the (updated) value at the end of the - place. This value should not contain any loan or borrow (and we check - it is the case). Note that this value is very likely to contain {!V.Bottom} - subvalues. - - [end_borrows]: if false, we only end the outer loans we find. If true, we - end all the loans and the borrows we find. - TODO: end_borrows is not necessary anymore. - *) -let prepare_lplace (config : C.config) (end_borrows : bool) (p : E.place) - (cf : V.typed_value -> m_fun) : m_fun = - fun ctx -> - log#ldebug - (lazy - ("prepare_lplace:" ^ "\n- p: " ^ place_to_string ctx p - ^ "\n- Initial context:\n" ^ eval_ctx_to_string ctx)); - (* Access the place *) - let access = Write in - let cc = update_ctx_along_write_place config access p in - (* End the borrows and loans, starting with the borrows *) - let cc = comp cc (drop_outer_borrows_loans_at_lplace config end_borrows p) in - (* Read the value and check it *) - let read_check cf : m_fun = - fun ctx -> - let v = read_place_unwrap config access p ctx in - (* Sanity checks *) - if end_borrows then ( - assert (not (loans_in_value v)); - assert (not (borrows_in_value v))) - else assert (not (outer_loans_in_value v)); - (* Continue *) - cf v ctx - in - (* Compose and apply the continuations *) - comp cc read_check cf ctx diff --git a/src/InterpreterProjectors.ml b/src/InterpreterProjectors.ml deleted file mode 100644 index 064b8969..00000000 --- a/src/InterpreterProjectors.ml +++ /dev/null @@ -1,543 +0,0 @@ -module T = Types -module V = Values -module E = Expressions -module C = Contexts -module Subst = Substitute -module L = Logging -open TypesUtils -open InterpreterUtils -open InterpreterBorrowsCore - -(** Auxiliary function. - - Apply a proj_borrows on a shared borrow. - Note that when projecting over shared values, we generate - {!V.abstract_shared_borrows}, not {!V.avalue}s. -*) -let rec apply_proj_borrows_on_shared_borrow (ctx : C.eval_ctx) - (fresh_reborrow : V.BorrowId.id -> V.BorrowId.id) - (regions : T.RegionId.Set.t) (v : V.typed_value) (ty : T.rty) : - V.abstract_shared_borrows = - (* Sanity check - TODO: move this elsewhere (here we perform the check at every - * recursive call which is a bit overkill...) *) - let ety = Subst.erase_regions ty in - assert (ety = v.V.ty); - (* Project - if there are no regions from the abstraction in the type, return [_] *) - if not (ty_has_regions_in_set regions ty) then [] - else - match (v.V.value, ty) with - | V.Concrete _, (T.Bool | T.Char | T.Integer _ | T.Str) -> [] - | V.Adt adt, T.Adt (id, region_params, tys) -> - (* Retrieve the types of the fields *) - let field_types = - Subst.ctx_adt_value_get_instantiated_field_rtypes ctx adt id - region_params tys - in - (* Project over the field values *) - let fields_types = List.combine adt.V.field_values field_types in - let proj_fields = - List.map - (fun (fv, fty) -> - apply_proj_borrows_on_shared_borrow ctx fresh_reborrow regions fv - fty) - fields_types - in - List.concat proj_fields - | V.Bottom, _ -> failwith "Unreachable" - | V.Borrow bc, T.Ref (r, ref_ty, kind) -> - (* Retrieve the bid of the borrow and the asb of the projected borrowed value *) - let bid, asb = - (* Not in the set: dive *) - match (bc, kind) with - | V.MutBorrow (bid, bv), T.Mut -> - (* Apply the projection on the borrowed value *) - let asb = - apply_proj_borrows_on_shared_borrow ctx fresh_reborrow regions - bv ref_ty - in - (bid, asb) - | V.SharedBorrow (_, bid), T.Shared -> - (* Lookup the shared value *) - let ek = ek_all in - let sv = lookup_loan ek bid ctx in - let asb = - match sv with - | _, Concrete (V.SharedLoan (_, sv)) - | _, Abstract (V.ASharedLoan (_, sv, _)) -> - apply_proj_borrows_on_shared_borrow ctx fresh_reborrow - regions sv ref_ty - | _ -> failwith "Unexpected" - in - (bid, asb) - | V.InactivatedMutBorrow _, _ -> - failwith - "Can't apply a proj_borrow over an inactivated mutable borrow" - | _ -> failwith "Unreachable" - in - let asb = - (* Check if the region is in the set of projected regions (note that - * we never project over static regions) *) - if region_in_set r regions then - let bid' = fresh_reborrow bid in - V.AsbBorrow bid' :: asb - else asb - in - asb - | V.Loan _, _ -> failwith "Unreachable" - | V.Symbolic s, _ -> - (* Check that the projection doesn't contain ended regions *) - assert ( - not (projections_intersect s.V.sv_ty ctx.ended_regions ty regions)); - [ V.AsbProjReborrows (s, ty) ] - | _ -> failwith "Unreachable" - -(** Apply (and reduce) a projector over borrows to a value. - - - [regions]: the regions we project - - [v]: the value over which we project - - [ty]: the projection type (is used to map borrows to regions, or to - interpret the borrows as belonging to some regions...). Remember that - [v] doesn't contain region information. - For instance, if we have: - [v <: ty] where: - - [v = mut_borrow l ...] - - [ty = Ref (r, ...)] - then we interpret the borrow [l] as belonging to region [r] - - Also, when applying projections on shared values, we need to apply - reborrows. This is a bit annoying because, with the way we compute - the projection on borrows, we can't update the context immediately. - Instead, we remember the list of borrows we have to insert in the - context *afterwards*. - - [check_symbolic_no_ended] controls whether we check or not whether - symbolic values don't contain already ended regions. - This check is activated when applying projectors upon calling a function - (because we need to check that function arguments don't contain ⊥), - but deactivated when expanding symbolic values: - {[ - fn f<'a,'b>(x : &'a mut u32, y : &'b mut u32) -> (&'a mut u32, &'b mut u32); - - let p = f(&mut x, &mut y); // p -> @s0 - assert(x == ...); // end 'a - let z = p.1; // HERE: the symbolic expansion of @s0 contains ended regions - ]} -*) -let rec apply_proj_borrows (check_symbolic_no_ended : bool) (ctx : C.eval_ctx) - (fresh_reborrow : V.BorrowId.id -> V.BorrowId.id) - (regions : T.RegionId.Set.t) (ancestors_regions : T.RegionId.Set.t) - (v : V.typed_value) (ty : T.rty) : V.typed_avalue = - (* Sanity check - TODO: move this elsewhere (here we perform the check at every - * recursive call which is a bit overkill...) *) - let ety = Substitute.erase_regions ty in - assert (ety = v.V.ty); - (* Project - if there are no regions from the abstraction in the type, return [_] *) - if not (ty_has_regions_in_set regions ty) then { V.value = V.AIgnored; ty } - else - let value : V.avalue = - match (v.V.value, ty) with - | V.Concrete cv, (T.Bool | T.Char | T.Integer _ | T.Str) -> V.AConcrete cv - | V.Adt adt, T.Adt (id, region_params, tys) -> - (* Retrieve the types of the fields *) - let field_types = - Subst.ctx_adt_value_get_instantiated_field_rtypes ctx adt id - region_params tys - in - (* Project over the field values *) - let fields_types = List.combine adt.V.field_values field_types in - let proj_fields = - List.map - (fun (fv, fty) -> - apply_proj_borrows check_symbolic_no_ended ctx fresh_reborrow - regions ancestors_regions fv fty) - fields_types - in - V.AAdt { V.variant_id = adt.V.variant_id; field_values = proj_fields } - | V.Bottom, _ -> failwith "Unreachable" - | V.Borrow bc, T.Ref (r, ref_ty, kind) -> - if - (* Check if the region is in the set of projected regions (note that - * we never project over static regions) *) - region_in_set r regions - then - (* In the set *) - let bc = - match (bc, kind) with - | V.MutBorrow (bid, bv), T.Mut -> - (* Remember the borrowed value we are about to project as a meta-value *) - let mv = bv in - (* Apply the projection on the borrowed value *) - let bv = - apply_proj_borrows check_symbolic_no_ended ctx - fresh_reborrow regions ancestors_regions bv ref_ty - in - V.AMutBorrow (mv, bid, bv) - | V.SharedBorrow (_, bid), T.Shared -> V.ASharedBorrow bid - | V.InactivatedMutBorrow _, _ -> - failwith - "Can't apply a proj_borrow over an inactivated mutable \ - borrow" - | _ -> failwith "Unreachable" - in - V.ABorrow bc - else - (* Not in the set: ignore *) - let bc = - match (bc, kind) with - | V.MutBorrow (bid, bv), T.Mut -> - (* Apply the projection on the borrowed value *) - let bv = - apply_proj_borrows check_symbolic_no_ended ctx - fresh_reborrow regions ancestors_regions bv ref_ty - in - (* If the borrow id is in the ancestor's regions, we still need - * to remember it *) - let opt_bid = - if region_in_set r ancestors_regions then Some bid else None - in - (* Return *) - V.AIgnoredMutBorrow (opt_bid, bv) - | V.SharedBorrow (_, bid), T.Shared -> - (* Lookup the shared value *) - let ek = ek_all in - let sv = lookup_loan ek bid ctx in - let asb = - match sv with - | _, Concrete (V.SharedLoan (_, sv)) - | _, Abstract (V.ASharedLoan (_, sv, _)) -> - apply_proj_borrows_on_shared_borrow ctx fresh_reborrow - regions sv ref_ty - | _ -> failwith "Unexpected" - in - V.AProjSharedBorrow asb - | V.InactivatedMutBorrow _, _ -> - failwith - "Can't apply a proj_borrow over an inactivated mutable \ - borrow" - | _ -> failwith "Unreachable" - in - V.ABorrow bc - | V.Loan _, _ -> failwith "Unreachable" - | V.Symbolic s, _ -> - (* Check that the projection doesn't contain already ended regions, - * if necessary *) - if check_symbolic_no_ended then ( - let ty1 = s.V.sv_ty in - let rset1 = ctx.ended_regions in - let ty2 = ty in - let rset2 = regions in - log#ldebug - (lazy - ("projections_intersect:" ^ "\n- ty1: " ^ rty_to_string ctx ty1 - ^ "\n- rset1: " - ^ T.RegionId.Set.to_string None rset1 - ^ "\n- ty2: " ^ rty_to_string ctx ty2 ^ "\n- rset2: " - ^ T.RegionId.Set.to_string None rset2 - ^ "\n")); - assert (not (projections_intersect ty1 rset1 ty2 rset2))); - V.ASymbolic (V.AProjBorrows (s, ty)) - | _ -> - log#lerror - (lazy - ("apply_proj_borrows: unexpected inputs:\n- input value: " - ^ typed_value_to_string ctx v - ^ "\n- proj rty: " ^ rty_to_string ctx ty)); - failwith "Unreachable" - in - { V.value; V.ty } - -(** Convert a symbolic expansion *which is not a borrow* to a value *) -let symbolic_expansion_non_borrow_to_value (sv : V.symbolic_value) - (see : V.symbolic_expansion) : V.typed_value = - let ty = Subst.erase_regions sv.V.sv_ty in - let value = - match see with - | SeConcrete cv -> V.Concrete cv - | SeAdt (variant_id, field_values) -> - let field_values = - List.map mk_typed_value_from_symbolic_value field_values - in - V.Adt { V.variant_id; V.field_values } - | SeMutRef (_, _) | SeSharedRef (_, _) -> - failwith "Unexpected symbolic reference expansion" - in - { V.value; V.ty } - -(** Convert a symbolic expansion to a value. - - If the expansion is a mutable reference expansion, it converts it to a borrow. - This function is meant to be used when reducing projectors over borrows, - during a symbolic expansion. - *) -let symbolic_expansion_non_shared_borrow_to_value (sv : V.symbolic_value) - (see : V.symbolic_expansion) : V.typed_value = - match see with - | SeMutRef (bid, bv) -> - let ty = Subst.erase_regions sv.V.sv_ty in - let bv = mk_typed_value_from_symbolic_value bv in - let value = V.Borrow (V.MutBorrow (bid, bv)) in - { V.value; ty } - | SeSharedRef (_, _) -> - failwith "Unexpected symbolic shared reference expansion" - | _ -> symbolic_expansion_non_borrow_to_value sv see - -(** Apply (and reduce) a projector over loans to a value. - - TODO: detailed comments. See [apply_proj_borrows] -*) -let apply_proj_loans_on_symbolic_expansion (regions : T.RegionId.Set.t) - (see : V.symbolic_expansion) (original_sv_ty : T.rty) : V.typed_avalue = - (* Sanity check: if we have a proj_loans over a symbolic value, it should - * contain regions which we will project *) - assert (ty_has_regions_in_set regions original_sv_ty); - (* Match *) - let (value, ty) : V.avalue * T.rty = - match (see, original_sv_ty) with - | SeConcrete _, (T.Bool | T.Char | T.Integer _ | T.Str) -> - (V.AIgnored, original_sv_ty) - | SeAdt (variant_id, field_values), T.Adt (_id, _region_params, _tys) -> - (* Project over the field values *) - let field_values = - List.map - (mk_aproj_loans_value_from_symbolic_value regions) - field_values - in - (V.AAdt { V.variant_id; field_values }, original_sv_ty) - | SeMutRef (bid, spc), T.Ref (r, ref_ty, T.Mut) -> - (* Sanity check *) - assert (spc.V.sv_ty = ref_ty); - (* Apply the projector to the borrowed value *) - let child_av = mk_aproj_loans_value_from_symbolic_value regions spc in - (* Check if the region is in the set of projected regions (note that - * we never project over static regions) *) - if region_in_set r regions then - (* In the set: keep *) - (V.ALoan (V.AMutLoan (bid, child_av)), ref_ty) - else - (* Not in the set: ignore *) - (V.ALoan (V.AIgnoredMutLoan (bid, child_av)), ref_ty) - | SeSharedRef (bids, spc), T.Ref (r, ref_ty, T.Shared) -> - (* Sanity check *) - assert (spc.V.sv_ty = ref_ty); - (* Apply the projector to the borrowed value *) - let child_av = mk_aproj_loans_value_from_symbolic_value regions spc in - (* Check if the region is in the set of projected regions (note that - * we never project over static regions) *) - if region_in_set r regions then - (* In the set: keep *) - let shared_value = mk_typed_value_from_symbolic_value spc in - (V.ALoan (V.ASharedLoan (bids, shared_value, child_av)), ref_ty) - else - (* Not in the set: ignore *) - (V.ALoan (V.AIgnoredSharedLoan child_av), ref_ty) - | _ -> failwith "Unreachable" - in - { V.value; V.ty } - -(** Auxiliary function. See [give_back_value]. - - Apply reborrows to a context. - - The [reborrows] input is a list of pairs (shared loan id, id to insert - in the shared loan). - This function is used when applying projectors on shared borrows: when - doing so, we might need to reborrow subvalues from the shared value. - For instance: - {[ - fn f<'a,'b,'c>(x : &'a 'b 'c u32) - ]} - When introducing the abstractions for 'a, 'b and 'c, we apply a projector - on some value [shared_borrow l : &'a &'b &'c u32]. - In the 'a abstraction, this shared borrow gets projected. However, when - reducing the projectors for the 'b and 'c abstractions, we need to make - sure that the borrows living in regions 'b and 'c live as long as those - regions. This is done by looking up the shared value and applying reborrows - on the borrows we find there (note that those reborrows apply on shared - borrows - easy - and mutable borrows - in this case, we reborrow the whole - borrow: [mut_borrow ... ~~> shared_loan {...} (mut_borrow ...)]). -*) -let apply_reborrows (reborrows : (V.BorrowId.id * V.BorrowId.id) list) - (ctx : C.eval_ctx) : C.eval_ctx = - (* This is a bit brutal, but whenever we insert a reborrow, we remove - * it from the list. This allows us to check that all the reborrows were - * applied before returning. - * We might reimplement that in a more efficient manner by using maps. *) - let reborrows = ref reborrows in - - (* Check if a value is a mutable borrow, and return its identifier if - it is the case *) - let get_borrow_in_mut_borrow (v : V.typed_value) : V.BorrowId.id option = - match v.V.value with - | V.Borrow lc -> ( - match lc with - | V.SharedBorrow (_, _) | V.InactivatedMutBorrow _ -> None - | V.MutBorrow (id, _) -> Some id) - | _ -> None - in - - (* Add the proper reborrows to a set of borrow ids (for a shared loan) *) - let insert_reborrows bids = - (* Find the reborrows to apply *) - let insert, reborrows' = - List.partition (fun (bid, _) -> V.BorrowId.Set.mem bid bids) !reborrows - in - reborrows := reborrows'; - let insert = List.map snd insert in - (* Insert the borrows *) - List.fold_left (fun bids bid -> V.BorrowId.Set.add bid bids) bids insert - in - - (* Get the list of reborrows for a given borrow id *) - let get_reborrows_for_bid bid = - (* Find the reborrows to apply *) - let insert, reborrows' = - List.partition (fun (bid', _) -> bid' = bid) !reborrows - in - reborrows := reborrows'; - List.map snd insert - in - - let borrows_to_set bids = - List.fold_left - (fun bids bid -> V.BorrowId.Set.add bid bids) - V.BorrowId.Set.empty bids - in - - (* Insert reborrows for a given borrow id into a given set of borrows *) - let insert_reborrows_for_bid bids bid = - (* Find the reborrows to apply *) - let insert = get_reborrows_for_bid bid in - (* Insert the borrows *) - List.fold_left (fun bids bid -> V.BorrowId.Set.add bid bids) bids insert - in - - let obj = - object - inherit [_] C.map_eval_ctx as super - - (** We may need to reborrow mutable borrows. Note that this doesn't - happen for aborrows *) - method! visit_typed_value env v = - match v.V.value with - | V.Borrow (V.MutBorrow (bid, bv)) -> - let insert = get_reborrows_for_bid bid in - let nbc = super#visit_MutBorrow env bid bv in - let nbc = { v with V.value = V.Borrow nbc } in - if insert = [] then (* No reborrows: do nothing special *) - nbc - else - (* There are reborrows: insert a shared loan *) - let insert = borrows_to_set insert in - let value = V.Loan (V.SharedLoan (insert, nbc)) in - let ty = v.V.ty in - { V.value; ty } - | _ -> super#visit_typed_value env v - - (** We reimplement {!visit_loan_content} (rather than one of the sub- - functions) on purpose: exhaustive matches are good for maintenance *) - method! visit_loan_content env lc = - match lc with - | V.SharedLoan (bids, sv) -> - (* Insert the reborrows *) - let bids = insert_reborrows bids in - (* Check if the contained value is a mutable borrow, in which - * case we might need to reborrow it by adding more borrow ids - * to the current set of borrows - by doing this small - * manipulation here, we accumulate the borrow ids in the same - * shared loan, right above the mutable borrow, and avoid - * stacking shared loans (note that doing this is not a problem - * from a soundness point of view, but it is a bit ugly...) *) - let bids = - match get_borrow_in_mut_borrow sv with - | None -> bids - | Some bid -> insert_reborrows_for_bid bids bid - in - (* Update and explore *) - super#visit_SharedLoan env bids sv - | V.MutLoan bid -> - (* Nothing special to do *) - super#visit_MutLoan env bid - - method! visit_aloan_content env lc = - match lc with - | V.ASharedLoan (bids, sv, av) -> - (* Insert the reborrows *) - let bids = insert_reborrows bids in - (* Similarly to the non-abstraction case: check if the shared - * value is a mutable borrow, to eventually insert more reborrows *) - (* Update and explore *) - let bids = - match get_borrow_in_mut_borrow sv with - | None -> bids - | Some bid -> insert_reborrows_for_bid bids bid - in - (* Update and explore *) - super#visit_ASharedLoan env bids sv av - | V.AIgnoredSharedLoan _ - | V.AMutLoan (_, _) - | V.AEndedMutLoan { given_back = _; child = _; given_back_meta = _ } - | V.AEndedSharedLoan (_, _) - | V.AIgnoredMutLoan (_, _) - | V.AEndedIgnoredMutLoan - { given_back = _; child = _; given_back_meta = _ } -> - (* Nothing particular to do *) - super#visit_aloan_content env lc - end - in - - (* Visit *) - let ctx = obj#visit_eval_ctx () ctx in - (* Check that there are no reborrows remaining *) - assert (!reborrows = []); - (* Return *) - ctx - -(** Auxiliary function to prepare reborrowing operations (used when - applying projectors). - - Returns two functions: - - a function to generate fresh re-borrow ids, and register the reborrows - - a function to apply the reborrows in a context - Those functions are of course stateful. - *) -let prepare_reborrows (config : C.config) (allow_reborrows : bool) : - (V.BorrowId.id -> V.BorrowId.id) * (C.eval_ctx -> C.eval_ctx) = - let reborrows : (V.BorrowId.id * V.BorrowId.id) list ref = ref [] in - (* The function to generate and register fresh reborrows *) - let fresh_reborrow (bid : V.BorrowId.id) : V.BorrowId.id = - if allow_reborrows then ( - let bid' = C.fresh_borrow_id () in - reborrows := (bid, bid') :: !reborrows; - bid') - else failwith "Unexpected reborrow" - in - (* The function to apply the reborrows in a context *) - let apply_registered_reborrows (ctx : C.eval_ctx) : C.eval_ctx = - match config.C.mode with - | C.ConcreteMode -> - assert (!reborrows = []); - ctx - | C.SymbolicMode -> - (* Apply the reborrows *) - apply_reborrows !reborrows ctx - in - (fresh_reborrow, apply_registered_reborrows) - -let apply_proj_borrows_on_input_value (config : C.config) (ctx : C.eval_ctx) - (regions : T.RegionId.Set.t) (ancestors_regions : T.RegionId.Set.t) - (v : V.typed_value) (ty : T.rty) : C.eval_ctx * V.typed_avalue = - let check_symbolic_no_ended = true in - let allow_reborrows = true in - (* Prepare the reborrows *) - let fresh_reborrow, apply_registered_reborrows = - prepare_reborrows config allow_reborrows - in - (* Apply the projector *) - let av = - apply_proj_borrows check_symbolic_no_ended ctx fresh_reborrow regions - ancestors_regions v ty - in - (* Apply the reborrows *) - let ctx = apply_registered_reborrows ctx in - (* Return *) - (ctx, av) diff --git a/src/InterpreterStatements.ml b/src/InterpreterStatements.ml deleted file mode 100644 index 4e61e683..00000000 --- a/src/InterpreterStatements.ml +++ /dev/null @@ -1,1370 +0,0 @@ -module T = Types -module V = Values -module E = Expressions -module C = Contexts -module Subst = Substitute -module A = LlbcAst -module L = Logging -open TypesUtils -open ValuesUtils -module Inv = Invariants -module S = SynthesizeSymbolic -open Errors -open Cps -open InterpreterUtils -open InterpreterProjectors -open InterpreterExpansion -open InterpreterPaths -open InterpreterExpressions - -(** The local logger *) -let log = L.statements_log - -(** Drop a value at a given place - TODO: factorize this with [assign_to_place] *) -let drop_value (config : C.config) (p : E.place) : cm_fun = - fun cf ctx -> - log#ldebug - (lazy - ("drop_value: place: " ^ place_to_string ctx p ^ "\n- Initial context:\n" - ^ eval_ctx_to_string ctx)); - (* Prepare the place (by ending the outer loans). - * Note that {!prepare_lplace} will use the [Write] access kind: - * it is ok, because when updating the value with {!Bottom} below, - * we will use the [Move] access *) - let end_borrows = false in - let prepare = prepare_lplace config end_borrows p in - (* Replace the value with {!Bottom} *) - let replace cf (v : V.typed_value) ctx = - (* Move the value at destination (that we will overwrite) to a dummy variable - * to preserve the borrows *) - let mv = read_place_unwrap config Write p ctx in - let ctx = C.ctx_push_dummy_var ctx mv in - (* Update the destination to ⊥ *) - let nv = { v with value = V.Bottom } in - let ctx = write_place_unwrap config Move p nv ctx in - log#ldebug - (lazy - ("drop_value: place: " ^ place_to_string ctx p ^ "\n- Final context:\n" - ^ eval_ctx_to_string ctx)); - cf ctx - in - (* Compose and apply *) - comp prepare replace cf ctx - -(** Push a dummy variable to the environment *) -let push_dummy_var (v : V.typed_value) : cm_fun = - fun cf ctx -> - let ctx = C.ctx_push_dummy_var ctx v in - cf ctx - -(** Pop a dummy variable from the environment *) -let pop_dummy_var (cf : V.typed_value -> m_fun) : m_fun = - fun ctx -> - let ctx, v = C.ctx_pop_dummy_var ctx in - cf v ctx - -(** Push an uninitialized variable to the environment *) -let push_uninitialized_var (var : A.var) : cm_fun = - fun cf ctx -> - let ctx = C.ctx_push_uninitialized_var ctx var in - cf ctx - -(** Push a list of uninitialized variables to the environment *) -let push_uninitialized_vars (vars : A.var list) : cm_fun = - fun cf ctx -> - let ctx = C.ctx_push_uninitialized_vars ctx vars in - cf ctx - -(** Push a variable to the environment *) -let push_var (var : A.var) (v : V.typed_value) : cm_fun = - fun cf ctx -> - let ctx = C.ctx_push_var ctx var v in - cf ctx - -(** Push a list of variables to the environment *) -let push_vars (vars : (A.var * V.typed_value) list) : cm_fun = - fun cf ctx -> - let ctx = C.ctx_push_vars ctx vars in - cf ctx - -(** Assign a value to a given place. - - Note that this function first pushes the value to assign in a dummy variable, - then prepares the destination (by ending borrows, etc.) before popping the - dummy variable and putting in its destination (after having checked that - preparing the destination didn't introduce ⊥). - *) -let assign_to_place (config : C.config) (rv : V.typed_value) (p : E.place) : - cm_fun = - fun cf ctx -> - log#ldebug - (lazy - ("assign_to_place:" ^ "\n- rv: " - ^ typed_value_to_string ctx rv - ^ "\n- p: " ^ place_to_string ctx p ^ "\n- Initial context:\n" - ^ eval_ctx_to_string ctx)); - (* Push the rvalue to a dummy variable, for bookkeeping *) - let cc = push_dummy_var rv in - (* Prepare the destination *) - let end_borrows = false in - let cc = comp cc (prepare_lplace config end_borrows p) in - (* Retrieve the rvalue from the dummy variable *) - let cc = comp cc (fun cf _lv -> pop_dummy_var cf) in - (* Update the destination *) - let move_dest cf (rv : V.typed_value) : m_fun = - fun ctx -> - (* Move the value at destination (that we will overwrite) to a dummy variable - * to preserve the borrows *) - let mv = read_place_unwrap config Write p ctx in - let ctx = C.ctx_push_dummy_var ctx mv in - (* Write to the destination *) - (* Checks - maybe the bookkeeping updated the rvalue and introduced bottoms *) - assert (not (bottom_in_value ctx.ended_regions rv)); - (* Update the destination *) - let ctx = write_place_unwrap config Write p rv ctx in - (* Debug *) - log#ldebug - (lazy - ("assign_to_place:" ^ "\n- rv: " - ^ typed_value_to_string ctx rv - ^ "\n- p: " ^ place_to_string ctx p ^ "\n- Final context:\n" - ^ eval_ctx_to_string ctx)); - (* Continue *) - cf ctx - in - (* Compose and apply *) - comp cc move_dest cf ctx - -(** Evaluate an assertion, when the scrutinee is not symbolic *) -let eval_assertion_concrete (config : C.config) (assertion : A.assertion) : - st_cm_fun = - fun cf ctx -> - (* There won't be any symbolic expansions: fully evaluate the operand *) - let eval_op = eval_operand config assertion.cond in - let eval_assert cf (v : V.typed_value) : m_fun = - fun ctx -> - match v.value with - | Concrete (Bool b) -> - (* Branch *) - if b = assertion.expected then cf Unit ctx else cf Panic ctx - | _ -> - raise - (Failure ("Expected a boolean, got: " ^ typed_value_to_string ctx v)) - in - (* Compose and apply *) - comp eval_op eval_assert cf ctx - -(** Evaluates an assertion. - - In the case the boolean under scrutinee is symbolic, we synthesize - a call to [assert ...] then continue in the success branch (and thus - expand the boolean to [true]). - *) -let eval_assertion (config : C.config) (assertion : A.assertion) : st_cm_fun = - fun cf ctx -> - (* Evaluate the operand *) - let eval_op = eval_operand config assertion.cond in - (* Evaluate the assertion *) - let eval_assert cf (v : V.typed_value) : m_fun = - fun ctx -> - assert (v.ty = T.Bool); - (* We make a choice here: we could completely decouple the concrete and - * symbolic executions here but choose not to. In the case where we - * know the concrete value of the boolean we test, we use this value - * even if we are in symbolic mode. Note that this case should be - * extremely rare... *) - match v.value with - | Concrete (Bool _) -> - (* Delegate to the concrete evaluation function *) - eval_assertion_concrete config assertion cf ctx - | Symbolic sv -> - assert (config.mode = C.SymbolicMode); - assert (sv.V.sv_ty = T.Bool); - (* Expand the symbolic value and call the proper continuation functions - * for the true and false cases - TODO: call an "assert" function instead *) - let cf_true : m_fun = fun ctx -> cf Unit ctx in - let cf_false : m_fun = fun ctx -> cf Panic ctx in - let expand = - expand_symbolic_bool config sv - (S.mk_opt_place_from_op assertion.cond ctx) - cf_true cf_false - in - expand ctx - | _ -> - raise - (Failure ("Expected a boolean, got: " ^ typed_value_to_string ctx v)) - in - (* Compose and apply *) - comp eval_op eval_assert cf ctx - -(** Updates the discriminant of a value at a given place. - - There are two situations: - - either the discriminant is already the proper one (in which case we - don't do anything) - - or it is not the proper one (because the variant is not the proper - one, or the value is actually {!V.Bottom} - this happens when - initializing ADT values), in which case we replace the value with - a variant with all its fields set to {!V.Bottom}. - For instance, something like: [Cons Bottom Bottom]. - *) -let set_discriminant (config : C.config) (p : E.place) - (variant_id : T.VariantId.id) : st_cm_fun = - fun cf ctx -> - log#ldebug - (lazy - ("set_discriminant:" ^ "\n- p: " ^ place_to_string ctx p - ^ "\n- variant id: " - ^ T.VariantId.to_string variant_id - ^ "\n- initial context:\n" ^ eval_ctx_to_string ctx)); - (* Access the value *) - let access = Write in - let cc = update_ctx_along_read_place config access p in - let end_borrows = false in - let cc = comp cc (prepare_lplace config end_borrows p) in - (* Update the value *) - let update_value cf (v : V.typed_value) : m_fun = - fun ctx -> - match (v.V.ty, v.V.value) with - | ( T.Adt (((T.AdtId _ | T.Assumed T.Option) as type_id), regions, types), - V.Adt av ) -> ( - (* There are two situations: - - either the discriminant is already the proper one (in which case we - don't do anything) - - or it is not the proper one, in which case we replace the value with - a variant with all its fields set to {!Bottom} - *) - match av.variant_id with - | None -> raise (Failure "Found a struct value while expected an enum") - | Some variant_id' -> - if variant_id' = variant_id then (* Nothing to do *) - cf Unit ctx - else - (* Replace the value *) - let bottom_v = - match type_id with - | T.AdtId def_id -> - compute_expanded_bottom_adt_value - ctx.type_context.type_decls def_id (Some variant_id) - regions types - | T.Assumed T.Option -> - assert (regions = []); - compute_expanded_bottom_option_value variant_id - (Collections.List.to_cons_nil types) - | _ -> raise (Failure "Unreachable") - in - assign_to_place config bottom_v p (cf Unit) ctx) - | ( T.Adt (((T.AdtId _ | T.Assumed T.Option) as type_id), regions, types), - V.Bottom ) -> - let bottom_v = - match type_id with - | T.AdtId def_id -> - compute_expanded_bottom_adt_value ctx.type_context.type_decls - def_id (Some variant_id) regions types - | T.Assumed T.Option -> - assert (regions = []); - compute_expanded_bottom_option_value variant_id - (Collections.List.to_cons_nil types) - | _ -> raise (Failure "Unreachable") - in - assign_to_place config bottom_v p (cf Unit) ctx - | _, V.Symbolic _ -> - assert (config.mode = SymbolicMode); - (* This is a bit annoying: in theory we should expand the symbolic value - * then set the discriminant, because in the case the discriminant is - * exactly the one we set, the fields are left untouched, and in the - * other cases they are set to Bottom. - * For now, we forbid setting the discriminant of a symbolic value: - * setting a discriminant should only be used to initialize a value, - * or reset an already initialized value, really. *) - raise (Failure "Unexpected value") - | _, (V.Adt _ | V.Bottom) -> raise (Failure "Inconsistent state") - | _, (V.Concrete _ | V.Borrow _ | V.Loan _) -> - raise (Failure "Unexpected value") - in - (* Compose and apply *) - comp cc update_value cf ctx - -(** Push a frame delimiter in the context's environment *) -let ctx_push_frame (ctx : C.eval_ctx) : C.eval_ctx = - { ctx with env = Frame :: ctx.env } - -(** Push a frame delimiter in the context's environment *) -let push_frame : cm_fun = fun cf ctx -> cf (ctx_push_frame ctx) - -(** Small helper: compute the type of the return value for a specific - instantiation of a non-local function. - *) -let get_non_local_function_return_type (fid : A.assumed_fun_id) - (region_params : T.erased_region list) (type_params : T.ety list) : T.ety = - (* [Box::free] has a special treatment *) - match (fid, region_params, type_params) with - | A.BoxFree, [], [ _ ] -> mk_unit_ty - | _ -> - (* Retrieve the function's signature *) - let sg = Assumed.get_assumed_sig fid in - (* Instantiate the return type *) - let tsubst = - Subst.make_type_subst - (List.map (fun v -> v.T.index) sg.type_params) - type_params - in - Subst.erase_regions_substitute_types tsubst sg.output - -let move_return_value (config : C.config) (cf : V.typed_value -> m_fun) : m_fun - = - fun ctx -> - let ret_vid = V.VarId.zero in - let cc = eval_operand config (E.Move (mk_place_from_var_id ret_vid)) in - cc cf ctx - -(** Pop the current frame. - - Drop all the local variables but the return variable, move the return - value out of the return variable, remove all the local variables (but not the - abstractions!) from the context, remove the {!C.Frame} indicator delimiting the - current frame and handle the return value to the continuation. - - TODO: rename (remove the "ctx_") - *) -let ctx_pop_frame (config : C.config) (cf : V.typed_value -> m_fun) : m_fun = - fun ctx -> - (* Debug *) - log#ldebug (lazy ("ctx_pop_frame:\n" ^ eval_ctx_to_string ctx)); - - (* List the local variables, but the return variable *) - let ret_vid = V.VarId.zero in - let rec list_locals env = - match env with - | [] -> raise (Failure "Inconsistent environment") - | C.Abs _ :: env -> list_locals env - | C.Var (None, _) :: env -> list_locals env - | C.Var (Some var, _) :: env -> - let locals = list_locals env in - if var.index <> ret_vid then var.index :: locals else locals - | C.Frame :: _ -> [] - in - let locals : V.VarId.id list = list_locals ctx.env in - (* Debug *) - log#ldebug - (lazy - ("ctx_pop_frame: locals in which to drop the outer loans: [" - ^ String.concat "," (List.map V.VarId.to_string locals) - ^ "]")); - - (* Move the return value out of the return variable *) - let cc = move_return_value config in - (* Sanity check *) - let cc = - comp_check_value cc (fun ret_value ctx -> - assert (not (bottom_in_value ctx.ended_regions ret_value))) - in - - (* Drop the outer *loans* we find in the local variables *) - let cf_drop_loans_in_locals cf (ret_value : V.typed_value) : m_fun = - (* Drop the loans *) - let end_borrows = false in - let locals = List.rev locals in - let cf_drop = - List.fold_left - (fun cf lid -> - drop_outer_borrows_loans_at_lplace config end_borrows - (mk_place_from_var_id lid) cf) - (cf ret_value) locals - in - (* Apply *) - cf_drop - in - let cc = comp cc cf_drop_loans_in_locals in - (* Debug *) - let cc = - comp_check_value cc (fun _ ctx -> - log#ldebug - (lazy - ("ctx_pop_frame: after dropping outer loans in local variables:\n" - ^ eval_ctx_to_string ctx))) - in - - (* Pop the frame - we remove the [Frame] delimiter, and reintroduce all - * the local variables (which may still contain borrow permissions - but - * no outer loans) as dummy variables in the caller frame *) - let rec pop env = - match env with - | [] -> raise (Failure "Inconsistent environment") - | C.Abs abs :: env -> C.Abs abs :: pop env - | C.Var (_, v) :: env -> C.Var (None, v) :: pop env - | C.Frame :: env -> (* Stop here *) env - in - let cf_pop cf (ret_value : V.typed_value) : m_fun = - fun ctx -> - let env = pop ctx.env in - let ctx = { ctx with env } in - cf ret_value ctx - in - (* Compose and apply *) - comp cc cf_pop cf ctx - -(** Pop the current frame and assign the returned value to its destination. *) -let pop_frame_assign (config : C.config) (dest : E.place) : cm_fun = - let cf_pop = ctx_pop_frame config in - let cf_assign cf ret_value : m_fun = - assign_to_place config ret_value dest cf - in - comp cf_pop cf_assign - -(** Auxiliary function - see [eval_non_local_function_call] *) -let eval_replace_concrete (_config : C.config) - (_region_params : T.erased_region list) (_type_params : T.ety list) : cm_fun - = - fun _cf _ctx -> raise Unimplemented - -(** Auxiliary function - see [eval_non_local_function_call] *) -let eval_box_new_concrete (config : C.config) - (region_params : T.erased_region list) (type_params : T.ety list) : cm_fun = - fun cf ctx -> - (* Check and retrieve the arguments *) - match (region_params, type_params, ctx.env) with - | ( [], - [ boxed_ty ], - Var (Some input_var, input_value) :: Var (_ret_var, _) :: C.Frame :: _ ) - -> - (* Required type checking *) - assert (input_value.V.ty = boxed_ty); - - (* Move the input value *) - let cf_move = - eval_operand config (E.Move (mk_place_from_var_id input_var.C.index)) - in - - (* Create the new box *) - let cf_create cf (moved_input_value : V.typed_value) : m_fun = - (* Create the box value *) - let box_ty = T.Adt (T.Assumed T.Box, [], [ boxed_ty ]) in - let box_v = - V.Adt { variant_id = None; field_values = [ moved_input_value ] } - in - let box_v = mk_typed_value box_ty box_v in - - (* Move this value to the return variable *) - let dest = mk_place_from_var_id V.VarId.zero in - let cf_assign = assign_to_place config box_v dest in - - (* Continue *) - cf_assign cf - in - - (* Compose and apply *) - comp cf_move cf_create cf ctx - | _ -> raise (Failure "Inconsistent state") - -(** Auxiliary function which factorizes code to evaluate [std::Deref::deref] - and [std::DerefMut::deref_mut] - see [eval_non_local_function_call] *) -let eval_box_deref_mut_or_shared_concrete (config : C.config) - (region_params : T.erased_region list) (type_params : T.ety list) - (is_mut : bool) : cm_fun = - fun cf ctx -> - (* Check the arguments *) - match (region_params, type_params, ctx.env) with - | ( [], - [ boxed_ty ], - Var (Some input_var, input_value) :: Var (_ret_var, _) :: C.Frame :: _ ) - -> - (* Required type checking. We must have: - - input_value.ty == & (mut) Box - - boxed_ty == ty - for some ty - *) - (let _, input_ty, ref_kind = ty_get_ref input_value.V.ty in - assert (match ref_kind with T.Shared -> not is_mut | T.Mut -> is_mut); - let input_ty = ty_get_box input_ty in - assert (input_ty = boxed_ty)); - - (* Borrow the boxed value *) - let p = - { E.var_id = input_var.C.index; projection = [ E.Deref; E.DerefBox ] } - in - let borrow_kind = if is_mut then E.Mut else E.Shared in - let rv = E.Ref (p, borrow_kind) in - let cf_borrow = eval_rvalue config rv in - - (* Move the borrow to its destination *) - let cf_move cf res : m_fun = - match res with - | Error EPanic -> - (* We can't get there by borrowing a value *) - raise (Failure "Unreachable") - | Ok borrowed_value -> - (* Move and continue *) - let destp = mk_place_from_var_id V.VarId.zero in - assign_to_place config borrowed_value destp cf - in - - (* Compose and apply *) - comp cf_borrow cf_move cf ctx - | _ -> raise (Failure "Inconsistent state") - -(** Auxiliary function - see [eval_non_local_function_call] *) -let eval_box_deref_concrete (config : C.config) - (region_params : T.erased_region list) (type_params : T.ety list) : cm_fun = - let is_mut = false in - eval_box_deref_mut_or_shared_concrete config region_params type_params is_mut - -(** Auxiliary function - see [eval_non_local_function_call] *) -let eval_box_deref_mut_concrete (config : C.config) - (region_params : T.erased_region list) (type_params : T.ety list) : cm_fun = - let is_mut = true in - eval_box_deref_mut_or_shared_concrete config region_params type_params is_mut - -(** Auxiliary function - see [eval_non_local_function_call]. - - [Box::free] is not handled the same way as the other assumed functions: - - in the regular case, whenever we need to evaluate an assumed function, - we evaluate the operands, push a frame, call a dedicated function - to correctly update the variables in the frame (and mimic the execution - of a body) and finally pop the frame - - in the case of [Box::free]: the value given to this function is often - of the form [Box(⊥)] because we can move the value out of the - box before freeing the box. It makes it invalid to see box_free as a - "regular" function: it is not valid to call a function with arguments - which contain [⊥]. For this reason, we execute [Box::free] as drop_value, - but this is a bit annoying with regards to the semantics... - - Followingly this function doesn't behave like the others: it does not expect - a stack frame to have been pushed, but rather simply behaves like {!drop_value}. - It thus updates the box value (by calling {!drop_value}) and updates - the destination (by setting it to [()]). -*) -let eval_box_free (config : C.config) (region_params : T.erased_region list) - (type_params : T.ety list) (args : E.operand list) (dest : E.place) : cm_fun - = - fun cf ctx -> - match (region_params, type_params, args) with - | [], [ boxed_ty ], [ E.Move input_box_place ] -> - (* Required type checking *) - let input_box = read_place_unwrap config Write input_box_place ctx in - (let input_ty = ty_get_box input_box.V.ty in - assert (input_ty = boxed_ty)); - - (* Drop the value *) - let cc = drop_value config input_box_place in - - (* Update the destination by setting it to [()] *) - let cc = comp cc (assign_to_place config mk_unit_value dest) in - - (* Continue *) - cc cf ctx - | _ -> raise (Failure "Inconsistent state") - -(** Auxiliary function - see [eval_non_local_function_call] *) -let eval_vec_function_concrete (_config : C.config) (_fid : A.assumed_fun_id) - (_region_params : T.erased_region list) (_type_params : T.ety list) : cm_fun - = - fun _cf _ctx -> raise Unimplemented - -(** Evaluate a non-local function call in concrete mode *) -let eval_non_local_function_call_concrete (config : C.config) - (fid : A.assumed_fun_id) (region_params : T.erased_region list) - (type_params : T.ety list) (args : E.operand list) (dest : E.place) : cm_fun - = - (* There are two cases (and this is extremely annoying): - - the function is not box_free - - the function is box_free - See {!eval_box_free} - *) - match fid with - | A.BoxFree -> - (* Degenerate case: box_free *) - eval_box_free config region_params type_params args dest - | _ -> - (* "Normal" case: not box_free *) - (* Evaluate the operands *) - (* let ctx, args_vl = eval_operands config ctx args in *) - let cf_eval_ops = eval_operands config args in - - (* Evaluate the call - * - * Style note: at some point we used {!comp_transmit} to - * transmit the result of {!eval_operands} above down to {!push_vars} - * below, without having to introduce an intermediary function call, - * but it made it less clear where the computed values came from, - * so we reversed the modifications. *) - let cf_eval_call cf (args_vl : V.typed_value list) : m_fun = - (* Push the stack frame: we initialize the frame with the return variable, - and one variable per input argument *) - let cc = push_frame in - - (* Create and push the return variable *) - let ret_vid = V.VarId.zero in - let ret_ty = - get_non_local_function_return_type fid region_params type_params - in - let ret_var = mk_var ret_vid (Some "@return") ret_ty in - let cc = comp cc (push_uninitialized_var ret_var) in - - (* Create and push the input variables *) - let input_vars = - V.VarId.mapi_from1 - (fun id (v : V.typed_value) -> (mk_var id None v.V.ty, v)) - args_vl - in - let cc = comp cc (push_vars input_vars) in - - (* "Execute" the function body. As the functions are assumed, here we call - * custom functions to perform the proper manipulations: we don't have - * access to a body. *) - let cf_eval_body : cm_fun = - match fid with - | A.Replace -> eval_replace_concrete config region_params type_params - | BoxNew -> eval_box_new_concrete config region_params type_params - | BoxDeref -> eval_box_deref_concrete config region_params type_params - | BoxDerefMut -> - eval_box_deref_mut_concrete config region_params type_params - | BoxFree -> - (* Should have been treated above *) raise (Failure "Unreachable") - | VecNew | VecPush | VecInsert | VecLen | VecIndex | VecIndexMut -> - eval_vec_function_concrete config fid region_params type_params - in - - let cc = comp cc cf_eval_body in - - (* Pop the frame *) - let cc = comp cc (pop_frame_assign config dest) in - - (* Continue *) - cc cf - in - (* Compose and apply *) - comp cf_eval_ops cf_eval_call - -(** Instantiate a function signature, introducing fresh abstraction ids and - region ids. This is mostly used in preparation of function calls, when - evaluating in symbolic mode of course. - - Note: there are no region parameters, because they should be erased. - - **Rk.:** this function is **stateful** and generates fresh abstraction ids - for the region groups. - *) -let instantiate_fun_sig (type_params : T.ety list) (sg : A.fun_sig) : - A.inst_fun_sig = - (* Generate fresh abstraction ids and create a substitution from region - * group ids to abstraction ids *) - let rg_abs_ids_bindings = - List.map - (fun rg -> - let abs_id = C.fresh_abstraction_id () in - (rg.T.id, abs_id)) - sg.regions_hierarchy - in - let asubst_map : V.AbstractionId.id T.RegionGroupId.Map.t = - List.fold_left - (fun mp (rg_id, abs_id) -> T.RegionGroupId.Map.add rg_id abs_id mp) - T.RegionGroupId.Map.empty rg_abs_ids_bindings - in - let asubst (rg_id : T.RegionGroupId.id) : V.AbstractionId.id = - T.RegionGroupId.Map.find rg_id asubst_map - in - (* Generate fresh regions and their substitutions *) - let _, rsubst, _ = Subst.fresh_regions_with_substs sg.region_params in - (* Generate the type substitution - * Note that we need the substitution to map the type variables to - * {!rty} types (not {!ety}). In order to do that, we convert the - * type parameters to types with regions. This is possible only - * if those types don't contain any regions. - * This is a current limitation of the analysis: there is still some - * work to do to properly handle full type parametrization. - * *) - let rtype_params = List.map ety_no_regions_to_rty type_params in - let tsubst = - Subst.make_type_subst - (List.map (fun v -> v.T.index) sg.type_params) - rtype_params - in - (* Substitute the signature *) - let inst_sig = Subst.substitute_signature asubst rsubst tsubst sg in - (* Return *) - inst_sig - -(** Helper - - Create abstractions (with no avalues, which have to be inserted afterwards) - from a list of abs region groups. - - [region_can_end]: gives the region groups from which we generate functions - which can end or not. - *) -let create_empty_abstractions_from_abs_region_groups (call_id : V.FunCallId.id) - (kind : V.abs_kind) (rgl : A.abs_region_group list) - (region_can_end : T.RegionGroupId.id -> bool) : V.abs list = - (* We use a reference to progressively create a map from abstraction ids - * to set of ancestor regions. Note that {!abs_to_ancestors_regions} [abs_id] - * returns the union of: - * - the regions of the ancestors of abs_id - * - the regions of abs_id - *) - let abs_to_ancestors_regions : T.RegionId.Set.t V.AbstractionId.Map.t ref = - ref V.AbstractionId.Map.empty - in - (* Auxiliary function to create one abstraction *) - let create_abs (back_id : T.RegionGroupId.id) (rg : A.abs_region_group) : - V.abs = - let abs_id = rg.T.id in - let original_parents = rg.parents in - let parents = - List.fold_left - (fun s pid -> V.AbstractionId.Set.add pid s) - V.AbstractionId.Set.empty rg.parents - in - let regions = - List.fold_left - (fun s rid -> T.RegionId.Set.add rid s) - T.RegionId.Set.empty rg.regions - in - let ancestors_regions = - List.fold_left - (fun acc parent_id -> - T.RegionId.Set.union acc - (V.AbstractionId.Map.find parent_id !abs_to_ancestors_regions)) - T.RegionId.Set.empty rg.parents - in - let ancestors_regions_union_current_regions = - T.RegionId.Set.union ancestors_regions regions - in - let can_end = region_can_end back_id in - abs_to_ancestors_regions := - V.AbstractionId.Map.add abs_id ancestors_regions_union_current_regions - !abs_to_ancestors_regions; - (* Create the abstraction *) - { - V.abs_id; - call_id; - back_id; - kind; - can_end; - parents; - original_parents; - regions; - ancestors_regions; - avalues = []; - } - in - (* Apply *) - T.RegionGroupId.mapi create_abs rgl - -(** Helper. - - Create a list of abstractions from a list of regions groups, and insert - them in the context. - - [region_can_end]: gives the region groups from which we generate functions - which can end or not. - - [compute_abs_avalues]: this function must compute, given an initialized, - empty (i.e., with no avalues) abstraction, compute the avalues which - should be inserted in this abstraction before we insert it in the context. - Note that this function may update the context: it is necessary when - computing borrow projections, for instance. -*) -let create_push_abstractions_from_abs_region_groups (call_id : V.FunCallId.id) - (kind : V.abs_kind) (rgl : A.abs_region_group list) - (region_can_end : T.RegionGroupId.id -> bool) - (compute_abs_avalues : - V.abs -> C.eval_ctx -> C.eval_ctx * V.typed_avalue list) - (ctx : C.eval_ctx) : C.eval_ctx = - (* Initialize the abstractions as empty (i.e., with no avalues) abstractions *) - let empty_absl = - create_empty_abstractions_from_abs_region_groups call_id kind rgl - region_can_end - in - - (* Compute and add the avalues to the abstractions, the insert the abstractions - * in the context. *) - let insert_abs (ctx : C.eval_ctx) (abs : V.abs) : C.eval_ctx = - (* Compute the values to insert in the abstraction *) - let ctx, avalues = compute_abs_avalues abs ctx in - (* Add the avalues to the abstraction *) - let abs = { abs with avalues } in - (* Insert the abstraction in the context *) - let ctx = { ctx with env = Abs abs :: ctx.env } in - (* Return *) - ctx - in - List.fold_left insert_abs ctx empty_absl - -(** Evaluate a statement *) -let rec eval_statement (config : C.config) (st : A.statement) : st_cm_fun = - fun cf ctx -> - (* Debugging *) - log#ldebug - (lazy - ("\n**About to evaluate statement**: [\n" - ^ statement_to_string_with_tab ctx st - ^ "\n]\n\n**Context**:\n" ^ eval_ctx_to_string ctx ^ "\n\n")); - - (* Expand the symbolic values if necessary - we need to do that before - * checking the invariants *) - let cc = greedy_expand_symbolic_values config in - (* Sanity check *) - let cc = comp cc (Inv.cf_check_invariants config) in - - (* Evaluate *) - let cf_eval_st cf : m_fun = - fun ctx -> - match st.content with - | A.Assign (p, rvalue) -> - (* Evaluate the rvalue *) - let cf_eval_rvalue = eval_rvalue config rvalue in - (* Assign *) - let cf_assign cf (res : (V.typed_value, eval_error) result) ctx = - log#ldebug - (lazy - ("about to assign to place: " ^ place_to_string ctx p - ^ "\n- Context:\n" ^ eval_ctx_to_string ctx)); - match res with - | Error EPanic -> cf Panic ctx - | Ok rv -> ( - let expr = assign_to_place config rv p (cf Unit) ctx in - (* Update the synthesized AST - here we store meta-information. - * We do it only in specific cases (it is not always useful, and - * also it can lead to issues - for instance, if we borrow an - * inactivated borrow, we later can't translate it to pure values...) *) - match rvalue with - | E.Use _ - | E.Ref (_, (E.Shared | E.Mut | E.TwoPhaseMut)) - | E.UnaryOp _ | E.BinaryOp _ | E.Discriminant _ | E.Aggregate _ -> - let rp = rvalue_get_place rvalue in - let rp = - match rp with - | Some rp -> Some (S.mk_mplace rp ctx) - | None -> None - in - S.synthesize_assignment (S.mk_mplace p ctx) rv rp expr) - in - - (* Compose and apply *) - comp cf_eval_rvalue cf_assign cf ctx - | A.AssignGlobal { dst; global } -> eval_global config dst global cf ctx - | A.FakeRead p -> - let expand_prim_copy = false in - let cf_prepare cf = - access_rplace_reorganize_and_read config expand_prim_copy Read p cf - in - let cf_continue cf v : m_fun = - fun ctx -> - assert (not (bottom_in_value ctx.ended_regions v)); - cf ctx - in - comp cf_prepare cf_continue (cf Unit) ctx - | A.SetDiscriminant (p, variant_id) -> - set_discriminant config p variant_id cf ctx - | A.Drop p -> drop_value config p (cf Unit) ctx - | A.Assert assertion -> eval_assertion config assertion cf ctx - | A.Call call -> eval_function_call config call cf ctx - | A.Panic -> cf Panic ctx - | A.Return -> cf Return ctx - | A.Break i -> cf (Break i) ctx - | A.Continue i -> cf (Continue i) ctx - | A.Nop -> cf Unit ctx - | A.Sequence (st1, st2) -> - (* Evaluate the first statement *) - let cf_st1 = eval_statement config st1 in - (* Evaluate the sequence *) - let cf_st2 cf res = - match res with - (* Evaluation successful: evaluate the second statement *) - | Unit -> eval_statement config st2 cf - (* Control-flow break: transmit. We enumerate the cases on purpose *) - | Panic | Break _ | Continue _ | Return -> cf res - in - (* Compose and apply *) - comp cf_st1 cf_st2 cf ctx - | A.Loop loop_body -> - (* For now, we don't support loops in symbolic mode *) - assert (config.C.mode = C.ConcreteMode); - (* Continuation for after we evaluate the loop body: depending the result - of doing one loop iteration: - - redoes a loop iteration - - exits the loop - - other... - - We need a specific function because of the {!Continue} case: in case we - continue, we might have to reevaluate the current loop body with the - new context (and repeat this an indefinite number of times). - *) - let rec reeval_loop_body res : m_fun = - match res with - | Return | Panic -> cf res - | Break i -> - (* Break out of the loop by calling the continuation *) - let res = if i = 0 then Unit else Break (i - 1) in - cf res - | Continue 0 -> - (* Re-evaluate the loop body *) - eval_statement config loop_body reeval_loop_body - | Continue i -> - (* Continue to an outer loop *) - cf (Continue (i - 1)) - | Unit -> - (* We can't get there. - * Note that if we decide not to fail here but rather do - * the same thing as for [Continue 0], we could make the - * code slightly simpler: calling {!reeval_loop_body} with - * {!Unit} would account for the first iteration of the loop. - * We prefer to write it this way for consistency and sanity, - * though. *) - raise (Failure "Unreachable") - in - (* Apply *) - eval_statement config loop_body reeval_loop_body ctx - | A.Switch (op, tgts) -> eval_switch config op tgts cf ctx - in - (* Compose and apply *) - comp cc cf_eval_st cf ctx - -and eval_global (config : C.config) (dest : V.VarId.id) - (gid : LA.GlobalDeclId.id) : st_cm_fun = - fun cf ctx -> - let global = C.ctx_lookup_global_decl ctx gid in - let place = { E.var_id = dest; projection = [] } in - match config.mode with - | ConcreteMode -> - (* Treat the evaluation of the global as a call to the global body (without arguments) *) - (eval_local_function_call_concrete config global.body_id [] [] [] place) - cf ctx - | SymbolicMode -> - (* Generate a fresh symbolic value. In the translation, this fresh symbolic value will be - * defined as equal to the value of the global (see {!S.synthesize_global_eval}). *) - let sval = - mk_fresh_symbolic_value V.Global (ety_no_regions_to_rty global.ty) - in - let cc = - assign_to_place config (mk_typed_value_from_symbolic_value sval) place - in - let e = cc (cf Unit) ctx in - S.synthesize_global_eval gid sval e - -(** Evaluate a switch *) -and eval_switch (config : C.config) (op : E.operand) (tgts : A.switch_targets) : - st_cm_fun = - fun cf ctx -> - (* We evaluate the operand in two steps: - * first we prepare it, then we check if its value is concrete or - * symbolic. If it is concrete, we can then evaluate the operand - * directly, otherwise we must first expand the value. - * Note that we can't fully evaluate the operand *then* expand the - * value if it is symbolic, because the value may have been move - * (and would thus floating in thin air...)! - * *) - (* Prepare the operand *) - let cf_eval_op cf : m_fun = eval_operand config op cf in - (* Match on the targets *) - let cf_match (cf : st_m_fun) (op_v : V.typed_value) : m_fun = - fun ctx -> - match tgts with - | A.If (st1, st2) -> ( - match op_v.value with - | V.Concrete (V.Bool b) -> - (* Evaluate the if and the branch body *) - let cf_branch cf : m_fun = - (* Branch *) - if b then eval_statement config st1 cf - else eval_statement config st2 cf - in - (* Compose the continuations *) - cf_branch cf ctx - | V.Symbolic sv -> - (* Expand the symbolic boolean, and continue by evaluating - * the branches *) - let cf_true : m_fun = eval_statement config st1 cf in - let cf_false : m_fun = eval_statement config st2 cf in - expand_symbolic_bool config sv - (S.mk_opt_place_from_op op ctx) - cf_true cf_false ctx - | _ -> raise (Failure "Inconsistent state")) - | A.SwitchInt (int_ty, stgts, otherwise) -> ( - match op_v.value with - | V.Concrete (V.Scalar sv) -> - (* Evaluate the branch *) - let cf_eval_branch cf = - (* Sanity check *) - assert (sv.V.int_ty = int_ty); - (* Find the branch *) - match List.find_opt (fun (svl, _) -> List.mem sv svl) stgts with - | None -> eval_statement config otherwise cf - | Some (_, tgt) -> eval_statement config tgt cf - in - (* Compose *) - cf_eval_branch cf ctx - | V.Symbolic sv -> - (* Expand the symbolic value and continue by evaluating the - * proper branches *) - let stgts = - List.map - (fun (cv, tgt_st) -> (cv, eval_statement config tgt_st cf)) - stgts - in - (* Several branches may be grouped together: every branch is described - * by a pair (list of values, branch expression). - * In order to do a symbolic evaluation, we make this "flat" by - * de-grouping the branches. *) - let stgts = - List.concat - (List.map - (fun (vl, st) -> List.map (fun v -> (v, st)) vl) - stgts) - in - (* Translate the otherwise branch *) - let otherwise = eval_statement config otherwise cf in - (* Expand and continue *) - expand_symbolic_int config sv - (S.mk_opt_place_from_op op ctx) - int_ty stgts otherwise ctx - | _ -> raise (Failure "Inconsistent state")) - in - (* Compose the continuations *) - comp cf_eval_op cf_match cf ctx - -(** Evaluate a function call (auxiliary helper for [eval_statement]) *) -and eval_function_call (config : C.config) (call : A.call) : st_cm_fun = - (* There are two cases: - - this is a local function, in which case we execute its body - - this is a non-local function, in which case there is a special treatment - *) - match call.func with - | A.Regular fid -> - eval_local_function_call config fid call.region_args call.type_args - call.args call.dest - | A.Assumed fid -> - eval_non_local_function_call config fid call.region_args call.type_args - call.args call.dest - -(** Evaluate a local (i.e., non-assumed) function call in concrete mode *) -and eval_local_function_call_concrete (config : C.config) (fid : A.FunDeclId.id) - (region_args : T.erased_region list) (type_args : T.ety list) - (args : E.operand list) (dest : E.place) : st_cm_fun = - fun cf ctx -> - assert (region_args = []); - - (* Retrieve the (correctly instantiated) body *) - let def = C.ctx_lookup_fun_decl ctx fid in - (* We can evaluate the function call only if it is not opaque *) - let body = - match def.body with - | None -> - raise - (Failure - ("Can't evaluate a call to an opaque function: " - ^ Print.name_to_string def.name)) - | Some body -> body - in - let tsubst = - Subst.make_type_subst - (List.map (fun v -> v.T.index) def.A.signature.type_params) - type_args - in - let locals, body_st = Subst.fun_body_substitute_in_body tsubst body in - - (* Evaluate the input operands *) - assert (List.length args = body.A.arg_count); - let cc = eval_operands config args in - - (* Push a frame delimiter - we use {!comp_transmit} to transmit the result - * of the operands evaluation from above to the functions afterwards, while - * ignoring it in this function *) - let cc = comp_transmit cc push_frame in - - (* Compute the initial values for the local variables *) - (* 1. Push the return value *) - let ret_var, locals = - match locals with - | ret_ty :: locals -> (ret_ty, locals) - | _ -> raise (Failure "Unreachable") - in - let input_locals, locals = - Collections.List.split_at locals body.A.arg_count - in - - let cc = comp_transmit cc (push_var ret_var (mk_bottom ret_var.var_ty)) in - - (* 2. Push the input values *) - let cf_push_inputs cf args = - let inputs = List.combine input_locals args in - (* Note that this function checks that the variables and their values - * have the same type (this is important) *) - push_vars inputs cf - in - let cc = comp cc cf_push_inputs in - - (* 3. Push the remaining local variables (initialized as {!Bottom}) *) - let cc = comp cc (push_uninitialized_vars locals) in - - (* Execute the function body *) - let cc = comp cc (eval_function_body config body_st) in - - (* Pop the stack frame and move the return value to its destination *) - let cf_finish cf res = - match res with - | Panic -> cf Panic - | Break _ | Continue _ | Unit -> raise (Failure "Unreachable") - | Return -> - (* Pop the stack frame, retrieve the return value, move it to - * its destination and continue *) - pop_frame_assign config dest (cf Unit) - in - let cc = comp cc cf_finish in - - (* Continue *) - cc cf ctx - -(** Evaluate a local (i.e., non-assumed) function call in symbolic mode *) -and eval_local_function_call_symbolic (config : C.config) (fid : A.FunDeclId.id) - (region_args : T.erased_region list) (type_args : T.ety list) - (args : E.operand list) (dest : E.place) : st_cm_fun = - fun cf ctx -> - (* Retrieve the (correctly instantiated) signature *) - let def = C.ctx_lookup_fun_decl ctx fid in - let sg = def.A.signature in - (* Instantiate the signature and introduce fresh abstraction and region ids - * while doing so *) - let inst_sg = instantiate_fun_sig type_args sg in - (* Sanity check *) - assert (List.length args = List.length def.A.signature.inputs); - (* Evaluate the function call *) - eval_function_call_symbolic_from_inst_sig config (A.Regular fid) inst_sg - region_args type_args args dest cf ctx - -(** Evaluate a function call in symbolic mode by using the function signature. - - This allows us to factorize the evaluation of local and non-local function - calls in symbolic mode: only their signatures matter. - *) -and eval_function_call_symbolic_from_inst_sig (config : C.config) - (fid : A.fun_id) (inst_sg : A.inst_fun_sig) - (region_args : T.erased_region list) (type_args : T.ety list) - (args : E.operand list) (dest : E.place) : st_cm_fun = - fun cf ctx -> - assert (region_args = []); - (* Generate a fresh symbolic value for the return value *) - let ret_sv_ty = inst_sg.A.output in - let ret_spc = mk_fresh_symbolic_value V.FunCallRet ret_sv_ty in - let ret_value = mk_typed_value_from_symbolic_value ret_spc in - let ret_av regions = - mk_aproj_loans_value_from_symbolic_value regions ret_spc - in - let args_places = List.map (fun p -> S.mk_opt_place_from_op p ctx) args in - let dest_place = Some (S.mk_mplace dest ctx) in - - (* Evaluate the input operands *) - let cc = eval_operands config args in - - (* Generate the abstractions and insert them in the context *) - let abs_ids = List.map (fun rg -> rg.T.id) inst_sg.regions_hierarchy in - let cf_call cf (args : V.typed_value list) : m_fun = - fun ctx -> - let args_with_rtypes = List.combine args inst_sg.A.inputs in - - (* Check the type of the input arguments *) - assert ( - List.for_all - (fun ((arg, rty) : V.typed_value * T.rty) -> - arg.V.ty = Subst.erase_regions rty) - args_with_rtypes); - (* Check that the input arguments don't contain symbolic values that can't - * be fed to functions (i.e., symbolic values output from function return - * values and which contain borrows of borrows can't be used as function - * inputs *) - assert ( - List.for_all - (fun arg -> - not (value_has_ret_symbolic_value_with_borrow_under_mut ctx arg)) - args); - - (* Initialize the abstractions and push them in the context. - * First, we define the function which, given an initialized, empty - * abstraction, computes the avalues which should be inserted inside. - *) - let compute_abs_avalues (abs : V.abs) (ctx : C.eval_ctx) : - C.eval_ctx * V.typed_avalue list = - (* Project over the input values *) - let ctx, args_projs = - List.fold_left_map - (fun ctx (arg, arg_rty) -> - apply_proj_borrows_on_input_value config ctx abs.regions - abs.ancestors_regions arg arg_rty) - ctx args_with_rtypes - in - (* Group the input and output values *) - (ctx, List.append args_projs [ ret_av abs.regions ]) - in - (* Actually initialize and insert the abstractions *) - let call_id = C.fresh_fun_call_id () in - let region_can_end _ = true in - let ctx = - create_push_abstractions_from_abs_region_groups call_id V.FunCall - inst_sg.A.regions_hierarchy region_can_end compute_abs_avalues ctx - in - - (* Apply the continuation *) - let expr = cf ctx in - - (* Synthesize the symbolic AST *) - S.synthesize_regular_function_call fid call_id abs_ids type_args args - args_places ret_spc dest_place expr - in - let cc = comp cc cf_call in - - (* Move the return value to its destination *) - let cc = comp cc (assign_to_place config ret_value dest) in - - (* End the abstractions which don't contain loans and don't have parent - * abstractions. - * We do the general, nested borrows case here: we end abstractions, then - * retry (because then we might end their children abstractions) - *) - let abs_ids = ref abs_ids in - let rec end_abs_with_no_loans cf : m_fun = - fun ctx -> - (* Find the abstractions which don't contain loans *) - let no_loans_abs, with_loans_abs = - List.partition - (fun abs_id -> - (* Lookup the abstraction *) - let abs = C.ctx_lookup_abs ctx abs_id in - (* Check if it has parents *) - V.AbstractionId.Set.is_empty abs.parents - (* Check if it contains non-ignored loans *) - && Option.is_none - (InterpreterBorrowsCore - .get_first_non_ignored_aloan_in_abstraction abs)) - !abs_ids - in - (* Check if there are abstractions to end *) - if no_loans_abs <> [] then ( - (* Update the reference to the list of asbtraction ids, for the recursive calls *) - abs_ids := with_loans_abs; - (* End the abstractions which can be ended *) - let no_loans_abs = V.AbstractionId.Set.of_list no_loans_abs in - let cc = InterpreterBorrows.end_abstractions config [] no_loans_abs in - (* Recursive call *) - let cc = comp cc end_abs_with_no_loans in - (* Continue *) - cc cf ctx) - else (* No abstractions to end: continue *) - cf ctx - in - (* Try to end the abstractions with no loans if: - * - the option is enabled - * - the function returns unit - * (see the documentation of {!config} for more information) - *) - let cc = - if config.return_unit_end_abs_with_no_loans && ty_is_unit inst_sg.output - then comp cc end_abs_with_no_loans - else cc - in - - (* Continue - note that we do as if the function call has been successful, - * by giving {!Unit} to the continuation, because we place us in the case - * where we haven't panicked. Of course, the translation needs to take the - * panic case into account... *) - cc (cf Unit) ctx - -(** Evaluate a non-local function call in symbolic mode *) -and eval_non_local_function_call_symbolic (config : C.config) - (fid : A.assumed_fun_id) (region_args : T.erased_region list) - (type_args : T.ety list) (args : E.operand list) (dest : E.place) : - st_cm_fun = - fun cf ctx -> - (* Sanity check: make sure the type parameters don't contain regions - - * this is a current limitation of our synthesis *) - assert ( - List.for_all - (fun ty -> not (ty_has_borrows ctx.type_context.type_infos ty)) - type_args); - - (* There are two cases (and this is extremely annoying): - - the function is not box_free - - the function is box_free - See {!eval_box_free} - *) - match fid with - | A.BoxFree -> - (* Degenerate case: box_free - note that this is not really a function - * call: no need to call a "synthesize_..." function *) - eval_box_free config region_args type_args args dest (cf Unit) ctx - | _ -> - (* "Normal" case: not box_free *) - (* In symbolic mode, the behaviour of a function call is completely defined - * by the signature of the function: we thus simply generate correctly - * instantiated signatures, and delegate the work to an auxiliary function *) - let inst_sig = - match fid with - | A.BoxFree -> - (* should have been treated above *) - raise (Failure "Unreachable") - | _ -> instantiate_fun_sig type_args (Assumed.get_assumed_sig fid) - in - - (* Evaluate the function call *) - eval_function_call_symbolic_from_inst_sig config (A.Assumed fid) inst_sig - region_args type_args args dest cf ctx - -(** Evaluate a non-local (i.e, assumed) function call such as [Box::deref] - (auxiliary helper for [eval_statement]) *) -and eval_non_local_function_call (config : C.config) (fid : A.assumed_fun_id) - (region_args : T.erased_region list) (type_args : T.ety list) - (args : E.operand list) (dest : E.place) : st_cm_fun = - fun cf ctx -> - (* Debug *) - log#ldebug - (lazy - (let type_args = - "[" ^ String.concat ", " (List.map (ety_to_string ctx) type_args) ^ "]" - in - let args = - "[" ^ String.concat ", " (List.map (operand_to_string ctx) args) ^ "]" - in - let dest = place_to_string ctx dest in - "eval_non_local_function_call:\n- fid:" ^ A.show_assumed_fun_id fid - ^ "\n- type_args: " ^ type_args ^ "\n- args: " ^ args ^ "\n- dest: " - ^ dest)); - - match config.mode with - | C.ConcreteMode -> - eval_non_local_function_call_concrete config fid region_args type_args - args dest (cf Unit) ctx - | C.SymbolicMode -> - eval_non_local_function_call_symbolic config fid region_args type_args - args dest cf ctx - -(** Evaluate a local (i.e, not assumed) function call (auxiliary helper for - [eval_statement]) *) -and eval_local_function_call (config : C.config) (fid : A.FunDeclId.id) - (region_args : T.erased_region list) (type_args : T.ety list) - (args : E.operand list) (dest : E.place) : st_cm_fun = - match config.mode with - | ConcreteMode -> - eval_local_function_call_concrete config fid region_args type_args args - dest - | SymbolicMode -> - eval_local_function_call_symbolic config fid region_args type_args args - dest - -(** Evaluate a statement seen as a function body (auxiliary helper for - [eval_statement]) *) -and eval_function_body (config : C.config) (body : A.statement) : st_cm_fun = - fun cf ctx -> - let cc = eval_statement config body in - let cf_finish cf res = - (* Note that we *don't* check the result ({!Panic}, {!Return}, etc.): we - * delegate the check to the caller. *) - (* Expand the symbolic values if necessary - we need to do that before - * checking the invariants *) - let cc = greedy_expand_symbolic_values config in - (* Sanity check *) - let cc = comp_check_ctx cc (Inv.check_invariants config) in - (* Continue *) - cc (cf res) - in - (* Compose and continue *) - comp cc cf_finish cf ctx diff --git a/src/InterpreterUtils.ml b/src/InterpreterUtils.ml deleted file mode 100644 index e6033e9e..00000000 --- a/src/InterpreterUtils.ml +++ /dev/null @@ -1,245 +0,0 @@ -module T = Types -module V = Values -module E = Expressions -module C = Contexts -module Subst = Substitute -module A = LlbcAst -module L = Logging -open Utils -open TypesUtils -module PA = Print.EvalCtxLlbcAst - -(** Some utilities *) - -let eval_ctx_to_string = Print.Contexts.eval_ctx_to_string -let ety_to_string = PA.ety_to_string -let rty_to_string = PA.rty_to_string -let symbolic_value_to_string = PA.symbolic_value_to_string -let borrow_content_to_string = PA.borrow_content_to_string -let loan_content_to_string = PA.loan_content_to_string -let aborrow_content_to_string = PA.aborrow_content_to_string -let aloan_content_to_string = PA.aloan_content_to_string -let aproj_to_string = PA.aproj_to_string -let typed_value_to_string = PA.typed_value_to_string -let typed_avalue_to_string = PA.typed_avalue_to_string -let place_to_string = PA.place_to_string -let operand_to_string = PA.operand_to_string -let statement_to_string ctx = PA.statement_to_string ctx "" " " -let statement_to_string_with_tab ctx = PA.statement_to_string ctx " " " " - -let same_symbolic_id (sv0 : V.symbolic_value) (sv1 : V.symbolic_value) : bool = - sv0.V.sv_id = sv1.V.sv_id - -let mk_var (index : V.VarId.id) (name : string option) (var_ty : T.ety) : A.var - = - { A.index; name; var_ty } - -(** Small helper - TODO: move *) -let mk_place_from_var_id (var_id : V.VarId.id) : E.place = - { var_id; projection = [] } - -(** Create a fresh symbolic value *) -let mk_fresh_symbolic_value (sv_kind : V.sv_kind) (ty : T.rty) : - V.symbolic_value = - let sv_id = C.fresh_symbolic_value_id () in - let svalue = { V.sv_kind; V.sv_id; V.sv_ty = ty } in - svalue - -(** Create a fresh symbolic value *) -let mk_fresh_symbolic_typed_value (sv_kind : V.sv_kind) (rty : T.rty) : - V.typed_value = - let ty = Subst.erase_regions rty in - (* Generate the fresh a symbolic value *) - let value = mk_fresh_symbolic_value sv_kind rty in - let value = V.Symbolic value in - { V.value; V.ty } - -(** Create a typed value from a symbolic value. *) -let mk_typed_value_from_symbolic_value (svalue : V.symbolic_value) : - V.typed_value = - let av = V.Symbolic svalue in - let av : V.typed_value = - { V.value = av; V.ty = Subst.erase_regions svalue.V.sv_ty } - in - av - -(** Create a loans projector value from a symbolic value. - - Checks if the projector will actually project some regions. If not, - returns {!V.AIgnored} ([_]). - - TODO: update to handle 'static - *) -let mk_aproj_loans_value_from_symbolic_value (regions : T.RegionId.Set.t) - (svalue : V.symbolic_value) : V.typed_avalue = - if ty_has_regions_in_set regions svalue.sv_ty then - let av = V.ASymbolic (V.AProjLoans (svalue, [])) in - let av : V.typed_avalue = { V.value = av; V.ty = svalue.V.sv_ty } in - av - else { V.value = V.AIgnored; ty = svalue.V.sv_ty } - -(** Create a borrows projector from a symbolic value *) -let mk_aproj_borrows_from_symbolic_value (proj_regions : T.RegionId.Set.t) - (svalue : V.symbolic_value) (proj_ty : T.rty) : V.aproj = - if ty_has_regions_in_set proj_regions proj_ty then - V.AProjBorrows (svalue, proj_ty) - else V.AIgnoredProjBorrows - -(** TODO: move *) -let borrow_is_asb (bid : V.BorrowId.id) (asb : V.abstract_shared_borrow) : bool - = - match asb with - | V.AsbBorrow bid' -> bid' = bid - | V.AsbProjReborrows _ -> false - -(** TODO: move *) -let borrow_in_asb (bid : V.BorrowId.id) (asb : V.abstract_shared_borrows) : bool - = - List.exists (borrow_is_asb bid) asb - -(** TODO: move *) -let remove_borrow_from_asb (bid : V.BorrowId.id) - (asb : V.abstract_shared_borrows) : V.abstract_shared_borrows = - let removed = ref 0 in - let asb = - List.filter - (fun asb -> - if not (borrow_is_asb bid asb) then true - else ( - removed := !removed + 1; - false)) - asb - in - assert (!removed = 1); - asb - -(** We sometimes need to return a value whose type may vary depending on - whether we find it in a "concrete" value or an abstraction (ex.: loan - contents when we perform environment lookups by using borrow ids) *) -type ('a, 'b) concrete_or_abs = Concrete of 'a | Abstract of 'b - -(** Generic loan content: concrete or abstract *) -type g_loan_content = (V.loan_content, V.aloan_content) concrete_or_abs - -(** Generic borrow content: concrete or abstract *) -type g_borrow_content = (V.borrow_content, V.aborrow_content) concrete_or_abs - -type abs_or_var_id = AbsId of V.AbstractionId.id | VarId of V.VarId.id option - -(** Utility exception *) -exception FoundBorrowContent of V.borrow_content - -(** Utility exception *) -exception FoundLoanContent of V.loan_content - -(** Utility exception *) -exception FoundABorrowContent of V.aborrow_content - -(** Utility exception *) -exception FoundGBorrowContent of g_borrow_content - -(** Utility exception *) -exception FoundGLoanContent of g_loan_content - -(** Utility exception *) -exception FoundAProjBorrows of V.symbolic_value * T.rty - -let symbolic_value_id_in_ctx (sv_id : V.SymbolicValueId.id) (ctx : C.eval_ctx) : - bool = - let obj = - object - inherit [_] C.iter_eval_ctx as super - - method! visit_Symbolic _ sv = - if sv.V.sv_id = sv_id then raise Found else () - - method! visit_aproj env aproj = - (match aproj with - | AProjLoans (sv, _) | AProjBorrows (sv, _) -> - if sv.V.sv_id = sv_id then raise Found else () - | AEndedProjLoans _ | AEndedProjBorrows _ | AIgnoredProjBorrows -> ()); - super#visit_aproj env aproj - - method! visit_abstract_shared_borrows _ asb = - let visit (asb : V.abstract_shared_borrow) : unit = - match asb with - | V.AsbBorrow _ -> () - | V.AsbProjReborrows (sv, _) -> - if sv.V.sv_id = sv_id then raise Found else () - in - List.iter visit asb - end - in - (* We use exceptions *) - try - obj#visit_eval_ctx () ctx; - false - with Found -> true - -(** Check that a symbolic value doesn't contain ended regions. - - Note that we don't check that the set of ended regions is empty: we - check that the set of ended regions doesn't intersect the set of - regions used in the type (this is more general). -*) -let symbolic_value_has_ended_regions (ended_regions : T.RegionId.Set.t) - (s : V.symbolic_value) : bool = - let regions = rty_regions s.V.sv_ty in - not (T.RegionId.Set.disjoint regions ended_regions) - -(** Check if a {!type:V.value} contains [⊥]. - - Note that this function is very general: it also checks wether - symbolic values contain already ended regions. - *) -let bottom_in_value (ended_regions : T.RegionId.Set.t) (v : V.typed_value) : - bool = - let obj = - object - inherit [_] V.iter_typed_value - method! visit_Bottom _ = raise Found - - method! visit_symbolic_value _ s = - if symbolic_value_has_ended_regions ended_regions s then raise Found - else () - end - in - (* We use exceptions *) - try - obj#visit_typed_value () v; - false - with Found -> true - -let value_has_ret_symbolic_value_with_borrow_under_mut (ctx : C.eval_ctx) - (v : V.typed_value) : bool = - let obj = - object - inherit [_] V.iter_typed_value - - method! visit_symbolic_value _ s = - match s.sv_kind with - | V.FunCallRet -> - if ty_has_borrow_under_mut ctx.type_context.type_infos s.sv_ty then - raise Found - else () - | V.SynthInput | V.SynthInputGivenBack | V.FunCallGivenBack - | V.SynthRetGivenBack -> - () - | V.Global -> () - end - in - (* We use exceptions *) - try - obj#visit_typed_value () v; - false - with Found -> true - -(** Return the place used in an rvalue, if that makes sense. - This is used to compute meta-data, to find pretty names. - *) -let rvalue_get_place (rv : E.rvalue) : E.place option = - match rv with - | Use (Copy p | Move p) -> Some p - | Use (Constant _) -> None - | Ref (p, _) -> Some p - | UnaryOp _ | BinaryOp _ | Discriminant _ | Aggregate _ -> None diff --git a/src/Invariants.ml b/src/Invariants.ml deleted file mode 100644 index 4a3364a6..00000000 --- a/src/Invariants.ml +++ /dev/null @@ -1,794 +0,0 @@ -(* The following module defines functions to check that some invariants - * are always maintained by evaluation contexts *) - -module T = Types -module V = Values -module E = Expressions -module C = Contexts -module Subst = Substitute -module A = LlbcAst -module L = Logging -open Cps -open TypesUtils -open InterpreterUtils -open InterpreterBorrowsCore - -(** The local logger *) -let log = L.invariants_log - -type borrow_info = { - loan_kind : T.ref_kind; - loan_in_abs : bool; - (* true if the loan was found in an abstraction *) - loan_ids : V.BorrowId.Set.t; - borrow_ids : V.BorrowId.Set.t; -} -[@@deriving show] - -type outer_borrow_info = { - outer_borrow : bool; - (* true if the value is borrowed *) - outer_shared : bool; (* true if the value is borrowed as shared *) -} - -let set_outer_mut (info : outer_borrow_info) : outer_borrow_info = - { info with outer_borrow = true } - -let set_outer_shared (_info : outer_borrow_info) : outer_borrow_info = - { outer_borrow = true; outer_shared = true } - -let ids_reprs_to_string (indent : string) - (reprs : V.BorrowId.id V.BorrowId.Map.t) : string = - V.BorrowId.Map.to_string (Some indent) V.BorrowId.to_string reprs - -let borrows_infos_to_string (indent : string) - (infos : borrow_info V.BorrowId.Map.t) : string = - V.BorrowId.Map.to_string (Some indent) show_borrow_info infos - -type borrow_kind = Mut | Shared | Inactivated - -(** Check that: - - loans and borrows are correctly related - - a two-phase borrow can't point to a value inside an abstraction - *) -let check_loans_borrows_relation_invariant (ctx : C.eval_ctx) : unit = - (* Link all the borrow ids to a representant - necessary because of shared - * borrows/loans *) - let ids_reprs : V.BorrowId.id V.BorrowId.Map.t ref = - ref V.BorrowId.Map.empty - in - (* Link all the id representants to a borrow information *) - let borrows_infos : borrow_info V.BorrowId.Map.t ref = - ref V.BorrowId.Map.empty - in - let context_to_string () : string = - eval_ctx_to_string ctx ^ "- representants:\n" - ^ ids_reprs_to_string " " !ids_reprs - ^ "\n- info:\n" - ^ borrows_infos_to_string " " !borrows_infos - in - (* Ignored loans - when we find an ignored loan while building the borrows_infos - * map, we register it in this list; once the borrows_infos map is completely - * built, we check that all the borrow ids of the ignored loans are in this - * map *) - let ignored_loans : (T.ref_kind * V.BorrowId.id) list ref = ref [] in - - (* first, register all the loans *) - (* Some utilities to register the loans *) - let register_ignored_loan (rkind : T.ref_kind) (bid : V.BorrowId.id) : unit = - ignored_loans := (rkind, bid) :: !ignored_loans - in - - let register_shared_loan (loan_in_abs : bool) (bids : V.BorrowId.Set.t) : unit - = - let reprs = !ids_reprs in - let infos = !borrows_infos in - (* Use the first borrow id as representant *) - let repr_bid = V.BorrowId.Set.min_elt bids in - assert (not (V.BorrowId.Map.mem repr_bid infos)); - (* Insert the mappings to the representant *) - let reprs = - V.BorrowId.Set.fold - (fun bid reprs -> - assert (not (V.BorrowId.Map.mem bid reprs)); - V.BorrowId.Map.add bid repr_bid reprs) - bids reprs - in - (* Insert the loan info *) - let info = - { - loan_kind = T.Shared; - loan_in_abs; - loan_ids = bids; - borrow_ids = V.BorrowId.Set.empty; - } - in - let infos = V.BorrowId.Map.add repr_bid info infos in - (* Update *) - ids_reprs := reprs; - borrows_infos := infos - in - - let register_mut_loan (loan_in_abs : bool) (bid : V.BorrowId.id) : unit = - let reprs = !ids_reprs in - let infos = !borrows_infos in - (* Sanity checks *) - assert (not (V.BorrowId.Map.mem bid reprs)); - assert (not (V.BorrowId.Map.mem bid infos)); - (* Add the mapping for the representant *) - let reprs = V.BorrowId.Map.add bid bid reprs in - (* Add the mapping for the loan info *) - let info = - { - loan_kind = T.Mut; - loan_in_abs; - loan_ids = V.BorrowId.Set.singleton bid; - borrow_ids = V.BorrowId.Set.empty; - } - in - let infos = V.BorrowId.Map.add bid info infos in - (* Update *) - ids_reprs := reprs; - borrows_infos := infos - in - - let loans_visitor = - object - inherit [_] C.iter_eval_ctx as super - - method! visit_Var _ binder v = - let inside_abs = false in - super#visit_Var inside_abs binder v - - method! visit_Abs _ abs = - let inside_abs = true in - super#visit_Abs inside_abs abs - - method! visit_loan_content inside_abs lc = - (* Register the loan *) - let _ = - match lc with - | V.SharedLoan (bids, _) -> register_shared_loan inside_abs bids - | V.MutLoan bid -> register_mut_loan inside_abs bid - in - (* Continue exploring *) - super#visit_loan_content inside_abs lc - - method! visit_aloan_content inside_abs lc = - let _ = - match lc with - | V.AMutLoan (bid, _) -> register_mut_loan inside_abs bid - | V.ASharedLoan (bids, _, _) -> register_shared_loan inside_abs bids - | V.AIgnoredMutLoan (bid, _) -> register_ignored_loan T.Mut bid - | V.AIgnoredSharedLoan _ - | V.AEndedMutLoan { given_back = _; child = _; given_back_meta = _ } - | V.AEndedSharedLoan (_, _) - | V.AEndedIgnoredMutLoan - { given_back = _; child = _; given_back_meta = _ } -> - (* Do nothing *) - () - in - (* Continue exploring *) - super#visit_aloan_content inside_abs lc - end - in - - (* Visit *) - let inside_abs = false in - loans_visitor#visit_eval_ctx inside_abs ctx; - - (* Then, register all the borrows *) - (* Some utilities to register the borrows *) - let find_info (bid : V.BorrowId.id) : borrow_info = - (* Find the representant *) - match V.BorrowId.Map.find_opt bid !ids_reprs with - | Some repr_bid -> - (* Lookup the info *) - V.BorrowId.Map.find repr_bid !borrows_infos - | None -> - let err = - "find_info: could not find the representant of borrow " - ^ V.BorrowId.to_string bid ^ ":\nContext:\n" ^ context_to_string () - in - log#serror err; - failwith err - in - - let update_info (bid : V.BorrowId.id) (info : borrow_info) : unit = - (* Find the representant *) - let repr_bid = V.BorrowId.Map.find bid !ids_reprs in - (* Update the info *) - let infos = - V.BorrowId.Map.update repr_bid - (fun x -> - match x with Some _ -> Some info | None -> failwith "Unreachable") - !borrows_infos - in - borrows_infos := infos - in - - let register_ignored_borrow = register_ignored_loan in - - let register_borrow (kind : borrow_kind) (bid : V.BorrowId.id) : unit = - (* Lookup the info *) - let info = find_info bid in - (* Check that the borrow kind is consistent *) - (match (info.loan_kind, kind) with - | T.Shared, (Shared | Inactivated) | T.Mut, Mut -> () - | _ -> failwith "Invariant not satisfied"); - (* An inactivated borrow can't point to a value inside an abstraction *) - assert (kind <> Inactivated || not info.loan_in_abs); - (* Insert the borrow id *) - let borrow_ids = info.borrow_ids in - assert (not (V.BorrowId.Set.mem bid borrow_ids)); - let info = { info with borrow_ids = V.BorrowId.Set.add bid borrow_ids } in - (* Update the info in the map *) - update_info bid info - in - - let borrows_visitor = - object - inherit [_] C.iter_eval_ctx as super - - method! visit_abstract_shared_borrows _ asb = - let visit asb = - match asb with - | V.AsbBorrow bid -> register_borrow Shared bid - | V.AsbProjReborrows _ -> () - in - List.iter visit asb - - method! visit_borrow_content env bc = - (* Register the loan *) - let _ = - match bc with - | V.SharedBorrow (_, bid) -> register_borrow Shared bid - | V.MutBorrow (bid, _) -> register_borrow Mut bid - | V.InactivatedMutBorrow (_, bid) -> register_borrow Inactivated bid - in - (* Continue exploring *) - super#visit_borrow_content env bc - - method! visit_aborrow_content env bc = - let _ = - match bc with - | V.AMutBorrow (_, bid, _) -> register_borrow Mut bid - | V.ASharedBorrow bid -> register_borrow Shared bid - | V.AIgnoredMutBorrow (Some bid, _) -> register_ignored_borrow Mut bid - | V.AIgnoredMutBorrow (None, _) - | V.AEndedMutBorrow _ | V.AEndedIgnoredMutBorrow _ - | V.AEndedSharedBorrow | V.AProjSharedBorrow _ -> - (* Do nothing *) - () - in - (* Continue exploring *) - super#visit_aborrow_content env bc - end - in - - (* Visit *) - borrows_visitor#visit_eval_ctx () ctx; - - (* Debugging *) - log#ldebug - (lazy ("\nAbout to check context invariant:\n" ^ context_to_string ())); - - (* Finally, check that everything is consistant *) - (* First, check all the ignored loans are present at the proper place *) - List.iter - (fun (rkind, bid) -> - let info = find_info bid in - assert (info.loan_kind = rkind)) - !ignored_loans; - - (* Then, check the borrow infos *) - V.BorrowId.Map.iter - (fun _ info -> - (* Note that we can't directly compare the sets - I guess they are - * different depending on the order in which we add the elements... *) - assert ( - V.BorrowId.Set.elements info.loan_ids - = V.BorrowId.Set.elements info.borrow_ids); - match info.loan_kind with - | T.Mut -> assert (V.BorrowId.Set.cardinal info.loan_ids = 1) - | T.Shared -> ()) - !borrows_infos - -(** Check that: - - borrows/loans can't contain ⊥ or inactivated mut borrows - - shared loans can't contain mutable loans - *) -let check_borrowed_values_invariant (config : C.config) (ctx : C.eval_ctx) : - unit = - let visitor = - object - inherit [_] C.iter_eval_ctx as super - - method! visit_Bottom info = - (* No ⊥ inside borrowed values *) - assert (config.C.allow_bottom_below_borrow || not info.outer_borrow) - - method! visit_ABottom _info = - (* ⊥ inside an abstraction is not the same as in a regular value *) - () - - method! visit_loan_content info lc = - (* Update the info *) - let info = - match lc with - | V.SharedLoan (_, _) -> set_outer_shared info - | V.MutLoan _ -> - (* No mutable loan inside a shared loan *) - assert (not info.outer_shared); - set_outer_mut info - in - (* Continue exploring *) - super#visit_loan_content info lc - - method! visit_borrow_content info bc = - (* Update the info *) - let info = - match bc with - | V.SharedBorrow _ -> set_outer_shared info - | V.InactivatedMutBorrow _ -> - assert (not info.outer_borrow); - set_outer_shared info - | V.MutBorrow (_, _) -> set_outer_mut info - in - (* Continue exploring *) - super#visit_borrow_content info bc - - method! visit_aloan_content info lc = - (* Update the info *) - let info = - match lc with - | V.AMutLoan (_, _) -> set_outer_mut info - | V.ASharedLoan (_, _, _) -> set_outer_shared info - | V.AEndedMutLoan { given_back = _; child = _; given_back_meta = _ } - -> - set_outer_mut info - | V.AEndedSharedLoan (_, _) -> set_outer_shared info - | V.AIgnoredMutLoan (_, _) -> set_outer_mut info - | V.AEndedIgnoredMutLoan - { given_back = _; child = _; given_back_meta = _ } -> - set_outer_mut info - | V.AIgnoredSharedLoan _ -> set_outer_shared info - in - (* Continue exploring *) - super#visit_aloan_content info lc - - method! visit_aborrow_content info bc = - (* Update the info *) - let info = - match bc with - | V.AMutBorrow (_, _, _) -> set_outer_mut info - | V.ASharedBorrow _ | V.AEndedSharedBorrow -> set_outer_shared info - | V.AIgnoredMutBorrow _ | V.AEndedMutBorrow _ - | V.AEndedIgnoredMutBorrow _ -> - set_outer_mut info - | V.AProjSharedBorrow _ -> set_outer_shared info - in - (* Continue exploring *) - super#visit_aborrow_content info bc - end - in - - (* Explore *) - let info = { outer_borrow = false; outer_shared = false } in - visitor#visit_eval_ctx info ctx - -let check_constant_value_type (cv : V.constant_value) (ty : T.ety) : unit = - match (cv, ty) with - | V.Scalar sv, T.Integer int_ty -> assert (sv.int_ty = int_ty) - | V.Bool _, T.Bool | V.Char _, T.Char | V.String _, T.Str -> () - | _ -> failwith "Erroneous typing" - -let check_typing_invariant (ctx : C.eval_ctx) : unit = - (* TODO: the type of aloans doens't make sense: they have a type - * of the shape [& (mut) T] where they should have type [T]... - * This messes a bit the type invariant checks when checking the - * children. In order to isolate the problem (for future modifications) - * we introduce function, so that we can easily spot all the involved - * places. - * *) - let aloan_get_expected_child_type (ty : 'r T.ty) : 'r T.ty = - let _, ty, _ = ty_get_ref ty in - ty - in - - let visitor = - object - inherit [_] C.iter_eval_ctx as super - method! visit_abs _ abs = super#visit_abs (Some abs) abs - - method! visit_typed_value info tv = - (* Check the current pair (value, type) *) - (match (tv.V.value, tv.V.ty) with - | V.Concrete cv, ty -> check_constant_value_type cv ty - (* ADT case *) - | V.Adt av, T.Adt (T.AdtId def_id, regions, tys) -> - (* Retrieve the definition to check the variant id, the number of - * parameters, etc. *) - let def = C.ctx_lookup_type_decl ctx def_id in - (* Check the number of parameters *) - assert (List.length regions = List.length def.region_params); - assert (List.length tys = List.length def.type_params); - (* Check that the variant id is consistent *) - (match (av.V.variant_id, def.T.kind) with - | Some variant_id, T.Enum variants -> - assert (T.VariantId.to_int variant_id < List.length variants) - | None, T.Struct _ -> () - | _ -> failwith "Erroneous typing"); - (* Check that the field types are correct *) - let field_types = - Subst.type_decl_get_instantiated_field_etypes def av.V.variant_id - tys - in - let fields_with_types = - List.combine av.V.field_values field_types - in - List.iter - (fun ((v, ty) : V.typed_value * T.ety) -> assert (v.V.ty = ty)) - fields_with_types - (* Tuple case *) - | V.Adt av, T.Adt (T.Tuple, regions, tys) -> - assert (regions = []); - assert (av.V.variant_id = None); - (* Check that the fields have the proper values - and check that there - * are as many fields as field types at the same time *) - let fields_with_types = List.combine av.V.field_values tys in - List.iter - (fun ((v, ty) : V.typed_value * T.ety) -> assert (v.V.ty = ty)) - fields_with_types - (* Assumed type case *) - | V.Adt av, T.Adt (T.Assumed aty_id, regions, tys) -> ( - assert (av.V.variant_id = None || aty_id = T.Option); - match (aty_id, av.V.field_values, regions, tys) with - (* Box *) - | T.Box, [ inner_value ], [], [ inner_ty ] - | T.Option, [ inner_value ], [], [ inner_ty ] -> - assert (inner_value.V.ty = inner_ty) - | T.Option, _, [], [ _ ] -> - (* Option::None: nothing to check *) - () - | T.Vec, fvs, [], [ vec_ty ] -> - List.iter - (fun (v : V.typed_value) -> assert (v.ty = vec_ty)) - fvs - | _ -> failwith "Erroneous type") - | V.Bottom, _ -> (* Nothing to check *) () - | V.Borrow bc, T.Ref (_, ref_ty, rkind) -> ( - match (bc, rkind) with - | V.SharedBorrow (_, bid), T.Shared - | V.InactivatedMutBorrow (_, bid), T.Mut -> ( - (* Lookup the borrowed value to check it has the proper type *) - let _, glc = lookup_loan ek_all bid ctx in - match glc with - | Concrete (V.SharedLoan (_, sv)) - | Abstract (V.ASharedLoan (_, sv, _)) -> - assert (sv.V.ty = ref_ty) - | _ -> failwith "Inconsistent context") - | V.MutBorrow (_, bv), T.Mut -> - assert ( - (* Check that the borrowed value has the proper type *) - bv.V.ty = ref_ty) - | _ -> failwith "Erroneous typing") - | V.Loan lc, ty -> ( - match lc with - | V.SharedLoan (_, sv) -> assert (sv.V.ty = ty) - | V.MutLoan bid -> ( - (* Lookup the borrowed value to check it has the proper type *) - let glc = lookup_borrow ek_all bid ctx in - match glc with - | Concrete (V.MutBorrow (_, bv)) -> assert (bv.V.ty = ty) - | Abstract (V.AMutBorrow (_, _, sv)) -> - assert (Subst.erase_regions sv.V.ty = ty) - | _ -> failwith "Inconsistent context")) - | V.Symbolic sv, ty -> - let ty' = Subst.erase_regions sv.V.sv_ty in - assert (ty' = ty) - | _ -> failwith "Erroneous typing"); - (* Continue exploring to inspect the subterms *) - super#visit_typed_value info tv - - (* TODO: there is a lot of duplication with {!visit_typed_value} - * which is quite annoying. There might be a way of factorizing - * that by factorizing the definitions of value and avalue, but - * the generation of visitors then doesn't work properly (TODO: - * report that). Still, it is actually not that problematic - * because this code shouldn't change a lot in the future, - * so the cost of maintenance should be pretty low. - * *) - method! visit_typed_avalue info atv = - (* Check the current pair (value, type) *) - (match (atv.V.value, atv.V.ty) with - | V.AConcrete cv, ty -> - check_constant_value_type cv (Subst.erase_regions ty) - (* ADT case *) - | V.AAdt av, T.Adt (T.AdtId def_id, regions, tys) -> - (* Retrieve the definition to check the variant id, the number of - * parameters, etc. *) - let def = C.ctx_lookup_type_decl ctx def_id in - (* Check the number of parameters *) - assert (List.length regions = List.length def.region_params); - assert (List.length tys = List.length def.type_params); - (* Check that the variant id is consistent *) - (match (av.V.variant_id, def.T.kind) with - | Some variant_id, T.Enum variants -> - assert (T.VariantId.to_int variant_id < List.length variants) - | None, T.Struct _ -> () - | _ -> failwith "Erroneous typing"); - (* Check that the field types are correct *) - let field_types = - Subst.type_decl_get_instantiated_field_rtypes def av.V.variant_id - regions tys - in - let fields_with_types = - List.combine av.V.field_values field_types - in - List.iter - (fun ((v, ty) : V.typed_avalue * T.rty) -> assert (v.V.ty = ty)) - fields_with_types - (* Tuple case *) - | V.AAdt av, T.Adt (T.Tuple, regions, tys) -> - assert (regions = []); - assert (av.V.variant_id = None); - (* Check that the fields have the proper values - and check that there - * are as many fields as field types at the same time *) - let fields_with_types = List.combine av.V.field_values tys in - List.iter - (fun ((v, ty) : V.typed_avalue * T.rty) -> assert (v.V.ty = ty)) - fields_with_types - (* Assumed type case *) - | V.AAdt av, T.Adt (T.Assumed aty_id, regions, tys) -> ( - assert (av.V.variant_id = None); - match (aty_id, av.V.field_values, regions, tys) with - (* Box *) - | T.Box, [ boxed_value ], [], [ boxed_ty ] -> - assert (boxed_value.V.ty = boxed_ty) - | _ -> failwith "Erroneous type") - | V.ABottom, _ -> (* Nothing to check *) () - | V.ABorrow bc, T.Ref (_, ref_ty, rkind) -> ( - match (bc, rkind) with - | V.AMutBorrow (_, _, av), T.Mut -> - (* Check that the child value has the proper type *) - assert (av.V.ty = ref_ty) - | V.ASharedBorrow bid, T.Shared -> ( - (* Lookup the borrowed value to check it has the proper type *) - let _, glc = lookup_loan ek_all bid ctx in - match glc with - | Concrete (V.SharedLoan (_, sv)) - | Abstract (V.ASharedLoan (_, sv, _)) -> - assert (sv.V.ty = Subst.erase_regions ref_ty) - | _ -> failwith "Inconsistent context") - | V.AIgnoredMutBorrow (_opt_bid, av), T.Mut -> - assert (av.V.ty = ref_ty) - | ( V.AEndedIgnoredMutBorrow - { given_back_loans_proj; child; given_back_meta = _ }, - T.Mut ) -> - assert (given_back_loans_proj.V.ty = ref_ty); - assert (child.V.ty = ref_ty) - | V.AProjSharedBorrow _, T.Shared -> () - | _ -> failwith "Inconsistent context") - | V.ALoan lc, aty -> ( - match lc with - | V.AMutLoan (bid, child_av) | V.AIgnoredMutLoan (bid, child_av) - -> ( - let borrowed_aty = aloan_get_expected_child_type aty in - assert (child_av.V.ty = borrowed_aty); - (* Lookup the borrowed value to check it has the proper type *) - let glc = lookup_borrow ek_all bid ctx in - match glc with - | Concrete (V.MutBorrow (_, bv)) -> - assert (bv.V.ty = Subst.erase_regions borrowed_aty) - | Abstract (V.AMutBorrow (_, _, sv)) -> - assert ( - Subst.erase_regions sv.V.ty - = Subst.erase_regions borrowed_aty) - | _ -> failwith "Inconsistent context") - | V.ASharedLoan (_, sv, child_av) | V.AEndedSharedLoan (sv, child_av) - -> - let borrowed_aty = aloan_get_expected_child_type aty in - assert (sv.V.ty = Subst.erase_regions borrowed_aty); - (* TODO: the type of aloans doesn't make sense, see above *) - assert (child_av.V.ty = borrowed_aty) - | V.AEndedMutLoan { given_back; child; given_back_meta = _ } - | V.AEndedIgnoredMutLoan { given_back; child; given_back_meta = _ } - -> - let borrowed_aty = aloan_get_expected_child_type aty in - assert (given_back.V.ty = borrowed_aty); - assert (child.V.ty = borrowed_aty) - | V.AIgnoredSharedLoan child_av -> - assert (child_av.V.ty = aloan_get_expected_child_type aty)) - | V.ASymbolic aproj, ty -> ( - let ty1 = Subst.erase_regions ty in - match aproj with - | V.AProjLoans (sv, _) -> - let ty2 = Subst.erase_regions sv.V.sv_ty in - assert (ty1 = ty2); - (* Also check that the symbolic values contain regions of interest - - * otherwise they should have been reduced to [_] *) - let abs = Option.get info in - assert (ty_has_regions_in_set abs.regions sv.V.sv_ty) - | V.AProjBorrows (sv, proj_ty) -> - let ty2 = Subst.erase_regions sv.V.sv_ty in - assert (ty1 = ty2); - (* Also check that the symbolic values contain regions of interest - - * otherwise they should have been reduced to [_] *) - let abs = Option.get info in - assert (ty_has_regions_in_set abs.regions proj_ty) - | V.AEndedProjLoans (_msv, given_back_ls) -> - List.iter - (fun (_, proj) -> - match proj with - | V.AProjBorrows (_sv, ty') -> assert (ty' = ty) - | V.AEndedProjBorrows _ | V.AIgnoredProjBorrows -> () - | _ -> failwith "Unexpected") - given_back_ls - | V.AEndedProjBorrows _ | V.AIgnoredProjBorrows -> ()) - | V.AIgnored, _ -> () - | _ -> failwith "Erroneous typing"); - (* Continue exploring to inspect the subterms *) - super#visit_typed_avalue info atv - end - in - visitor#visit_eval_ctx (None : V.abs option) ctx - -type proj_borrows_info = { - abs_id : V.AbstractionId.id; - regions : T.RegionId.Set.t; - proj_ty : T.rty; - as_shared_value : bool; (** True if the value is below a shared borrow *) -} -[@@deriving show] - -type proj_loans_info = { - abs_id : V.AbstractionId.id; - regions : T.RegionId.Set.t; -} -[@@deriving show] - -type sv_info = { - ty : T.rty; - env_count : int; - aproj_borrows : proj_borrows_info list; - aproj_loans : proj_loans_info list; -} -[@@deriving show] - -(** Check the invariants over the symbolic values. - - - a symbolic value can't be both in proj_borrows and in the concrete env - (this is why we preemptively expand copyable symbolic values) - - if a symbolic value contains regions: there is at most one occurrence - of this value in the concrete env - - if there is an aproj_borrows in the environment, there must also be a - corresponding aproj_loans - - aproj_loans are mutually disjoint - - TODO: aproj_borrows are mutually disjoint - - the union of the aproj_loans contains the aproj_borrows applied on the - same symbolic values - *) -let check_symbolic_values (_config : C.config) (ctx : C.eval_ctx) : unit = - (* Small utility *) - let module M = V.SymbolicValueId.Map in - let infos : sv_info M.t ref = ref M.empty in - let lookup_info (sv : V.symbolic_value) : sv_info = - match M.find_opt sv.V.sv_id !infos with - | Some info -> info - | None -> - { ty = sv.sv_ty; env_count = 0; aproj_borrows = []; aproj_loans = [] } - in - let update_info (sv : V.symbolic_value) (info : sv_info) = - infos := M.add sv.sv_id info !infos - in - let add_env_sv (sv : V.symbolic_value) : unit = - let info = lookup_info sv in - let info = { info with env_count = info.env_count + 1 } in - update_info sv info - in - let add_aproj_borrows (sv : V.symbolic_value) abs_id regions proj_ty - as_shared_value : unit = - let info = lookup_info sv in - let binfo = { abs_id; regions; proj_ty; as_shared_value } in - let info = { info with aproj_borrows = binfo :: info.aproj_borrows } in - update_info sv info - in - let add_aproj_loans (sv : V.symbolic_value) abs_id regions : unit = - let info = lookup_info sv in - let linfo = { abs_id; regions } in - let info = { info with aproj_loans = linfo :: info.aproj_loans } in - update_info sv info - in - (* Visitor *) - let obj = - object - inherit [_] C.iter_eval_ctx as super - method! visit_abs _ abs = super#visit_abs (Some abs) abs - method! visit_Symbolic _ sv = add_env_sv sv - - method! visit_abstract_shared_borrows abs asb = - let abs = Option.get abs in - let visit asb = - match asb with - | V.AsbBorrow _ -> () - | AsbProjReborrows (sv, proj_ty) -> - add_aproj_borrows sv abs.abs_id abs.regions proj_ty true - in - List.iter visit asb - - method! visit_aproj abs aproj = - (let abs = Option.get abs in - match aproj with - | AProjLoans (sv, _) -> add_aproj_loans sv abs.abs_id abs.regions - | AProjBorrows (sv, proj_ty) -> - add_aproj_borrows sv abs.abs_id abs.regions proj_ty false - | AEndedProjLoans _ | AEndedProjBorrows _ | AIgnoredProjBorrows -> ()); - super#visit_aproj abs aproj - end - in - (* Collect the information *) - obj#visit_eval_ctx None ctx; - log#ldebug - (lazy - ("check_symbolic_values: collected information:\n" - ^ V.SymbolicValueId.Map.to_string (Some " ") show_sv_info !infos)); - (* Check *) - let check_info _id info = - (* TODO: check that: - * - the borrows are mutually disjoint - *) - (* A symbolic value can't be both in the regular environment and inside - * projectors of borrows in abstractions *) - assert (info.env_count = 0 || info.aproj_borrows = []); - (* A symbolic value containing borrows can't be duplicated (i.e., copied): - * it must be expanded first *) - if ty_has_borrows ctx.type_context.type_infos info.ty then - assert (info.env_count <= 1); - (* A duplicated symbolic value is necessarily primitively copyable *) - assert (info.env_count <= 1 || ty_is_primitively_copyable info.ty); - - assert (info.aproj_borrows = [] || info.aproj_loans <> []); - (* At the same time: - * - check that the loans don't intersect - * - compute the set of regions for which we project loans - *) - (* Check that the loan projectors contain the region projectors *) - let loan_regions = - List.fold_left - (fun regions linfo -> - let regions = - T.RegionId.Set.fold - (fun rid regions -> - assert (not (T.RegionId.Set.mem rid regions)); - T.RegionId.Set.add rid regions) - regions linfo.regions - in - regions) - T.RegionId.Set.empty info.aproj_loans - in - (* Check that the union of the loan projectors contains the borrow projections. *) - List.iter - (fun binfo -> - assert ( - projection_contains info.ty loan_regions binfo.proj_ty binfo.regions)) - info.aproj_borrows; - () - in - - M.iter check_info !infos - -let check_invariants (config : C.config) (ctx : C.eval_ctx) : unit = - if config.C.check_invariants then ( - log#ldebug (lazy "Checking invariants"); - check_loans_borrows_relation_invariant ctx; - check_borrowed_values_invariant config ctx; - check_typing_invariant ctx; - check_symbolic_values config ctx) - else log#ldebug (lazy "Not checking invariants (check is not activated)") - -(** Same as {!check_invariants}, but written in CPS *) -let cf_check_invariants (config : C.config) : cm_fun = - fun cf ctx -> - check_invariants config ctx; - cf ctx diff --git a/src/LlbcAst.ml b/src/LlbcAst.ml deleted file mode 100644 index 1b08f1ea..00000000 --- a/src/LlbcAst.ml +++ /dev/null @@ -1,205 +0,0 @@ -open Names -open Types -open Values -open Expressions -open Identifiers -module FunDeclId = IdGen () -module GlobalDeclId = IdGen () -open Meta - -(** A variable, as used in a function definition *) -type var = { - index : VarId.id; (** Unique variable identifier *) - name : string option; - var_ty : ety; - (** The variable type - erased type, because variables are not used - ** in function signatures: they are only used to declare the list of - ** variables manipulated by a function body *) -} -[@@deriving show] - -type assumed_fun_id = - | Replace (** [core::mem::replace] *) - | BoxNew - | BoxDeref (** [core::ops::deref::Deref::>::deref] *) - | BoxDerefMut - (** [core::ops::deref::DerefMut::>::deref_mut] *) - | BoxFree - | VecNew - | VecPush - | VecInsert - | VecLen - | VecIndex (** [core::ops::index::Index::index, usize>] *) - | VecIndexMut - (** [core::ops::index::IndexMut::index_mut, usize>] *) -[@@deriving show, ord] - -type fun_id = Regular of FunDeclId.id | Assumed of assumed_fun_id -[@@deriving show, ord] - -type global_assignment = { dst : VarId.id; global : GlobalDeclId.id } -[@@deriving show] - -type assertion = { cond : operand; expected : bool } [@@deriving show] - -type abs_region_group = (AbstractionId.id, RegionId.id) g_region_group -[@@deriving show] - -type abs_region_groups = (AbstractionId.id, RegionId.id) g_region_groups -[@@deriving show] - -(** A function signature, as used when declaring functions *) -type fun_sig = { - region_params : region_var list; - num_early_bound_regions : int; - regions_hierarchy : region_var_groups; - type_params : type_var list; - inputs : sty list; - output : sty; -} -[@@deriving show] - -(** A function signature, after instantiation *) -type inst_fun_sig = { - regions_hierarchy : abs_region_groups; - inputs : rty list; - output : rty; -} -[@@deriving show] - -type call = { - func : fun_id; - region_args : erased_region list; - type_args : ety list; - args : operand list; - dest : place; -} -[@@deriving show] - -(** Ancestor for [typed_value] iter visitor *) -class ['self] iter_statement_base = - object (_self : 'self) - inherit [_] VisitorsRuntime.iter - - method visit_global_assignment : 'env -> global_assignment -> unit = - fun _ _ -> () - - method visit_meta : 'env -> meta -> unit = fun _ _ -> () - method visit_place : 'env -> place -> unit = fun _ _ -> () - method visit_rvalue : 'env -> rvalue -> unit = fun _ _ -> () - method visit_id : 'env -> VariantId.id -> unit = fun _ _ -> () - method visit_assertion : 'env -> assertion -> unit = fun _ _ -> () - method visit_operand : 'env -> operand -> unit = fun _ _ -> () - method visit_call : 'env -> call -> unit = fun _ _ -> () - method visit_integer_type : 'env -> integer_type -> unit = fun _ _ -> () - method visit_scalar_value : 'env -> scalar_value -> unit = fun _ _ -> () - end - -(** Ancestor for [typed_value] map visitor *) -class ['self] map_statement_base = - object (_self : 'self) - inherit [_] VisitorsRuntime.map - - method visit_global_assignment - : 'env -> global_assignment -> global_assignment = - fun _ x -> x - - method visit_meta : 'env -> meta -> meta = fun _ x -> x - method visit_place : 'env -> place -> place = fun _ x -> x - method visit_rvalue : 'env -> rvalue -> rvalue = fun _ x -> x - method visit_id : 'env -> VariantId.id -> VariantId.id = fun _ x -> x - method visit_assertion : 'env -> assertion -> assertion = fun _ x -> x - method visit_operand : 'env -> operand -> operand = fun _ x -> x - method visit_call : 'env -> call -> call = fun _ x -> x - - method visit_integer_type : 'env -> integer_type -> integer_type = - fun _ x -> x - - method visit_scalar_value : 'env -> scalar_value -> scalar_value = - fun _ x -> x - end - -type statement = { - meta : meta; (** The statement meta-data *) - content : raw_statement; (** The statement itself *) -} - -and raw_statement = - | Assign of place * rvalue - | AssignGlobal of global_assignment - | FakeRead of place - | SetDiscriminant of place * VariantId.id - | Drop of place - | Assert of assertion - | Call of call - | Panic - | Return - | Break of int - (** Break to (outer) loop. The [int] identifies the loop to break to: - * 0: break to the first outer loop (the current loop) - * 1: break to the second outer loop - * ... - *) - | Continue of int - (** Continue to (outer) loop. The loop identifier works - the same way as for {!Break} *) - | Nop - | Sequence of statement * statement - | Switch of operand * switch_targets - | Loop of statement - -and switch_targets = - | If of statement * statement (** Gives the "if" and "else" blocks *) - | SwitchInt of integer_type * (scalar_value list * statement) list * statement - (** The targets for a switch over an integer are: - - the list [(matched values, statement to execute)] - We need a list for the matched values in case we do something like this: - [switch n { 0 | 1 => ..., _ => ... }] - - the "otherwise" statement - Also note that we precise the type of the integer (uint32, int64, etc.) - which we switch on. *) -[@@deriving - show, - visitors - { - name = "iter_statement"; - variety = "iter"; - ancestors = [ "iter_statement_base" ]; - nude = true (* Don't inherit {!VisitorsRuntime.iter} *); - concrete = true; - }, - visitors - { - name = "map_statement"; - variety = "map"; - ancestors = [ "map_statement_base" ]; - nude = true (* Don't inherit {!VisitorsRuntime.iter} *); - concrete = true; - }] - -type fun_body = { - meta : meta; - arg_count : int; - locals : var list; - body : statement; -} -[@@deriving show] - -type fun_decl = { - def_id : FunDeclId.id; - meta : meta; - name : fun_name; - signature : fun_sig; - body : fun_body option; - is_global_decl_body : bool; -} -[@@deriving show] - -type global_decl = { - def_id : GlobalDeclId.id; - meta : meta; - body_id : FunDeclId.id; - name : global_name; - ty : ety; -} -[@@deriving show] diff --git a/src/LlbcAstUtils.ml b/src/LlbcAstUtils.ml deleted file mode 100644 index 46711d0a..00000000 --- a/src/LlbcAstUtils.ml +++ /dev/null @@ -1,73 +0,0 @@ -open LlbcAst -open Utils -module T = Types - -(** Check if a {!type:LlbcAst.statement} contains loops *) -let statement_has_loops (st : statement) : bool = - let obj = - object - inherit [_] iter_statement - method! visit_Loop _ _ = raise Found - end - in - try - obj#visit_statement () st; - false - with Found -> true - -(** Check if a {!type:LlbcAst.fun_decl} contains loops *) -let fun_decl_has_loops (fd : fun_decl) : bool = - match fd.body with - | Some body -> statement_has_loops body.body - | None -> false - -let lookup_fun_sig (fun_id : fun_id) (fun_decls : fun_decl FunDeclId.Map.t) : - fun_sig = - match fun_id with - | Regular id -> (FunDeclId.Map.find id fun_decls).signature - | Assumed aid -> Assumed.get_assumed_sig aid - -let lookup_fun_name (fun_id : fun_id) (fun_decls : fun_decl FunDeclId.Map.t) : - Names.fun_name = - match fun_id with - | Regular id -> (FunDeclId.Map.find id fun_decls).name - | Assumed aid -> Assumed.get_assumed_name aid - -(** Small utility: list the transitive parents of a region var group. - We don't do that in an efficient manner, but it doesn't matter. - - TODO: rename to "list_ancestors_..." - - This list *doesn't* include the current region. - *) -let rec list_parent_region_groups (sg : fun_sig) (gid : T.RegionGroupId.id) : - T.RegionGroupId.Set.t = - let rg = T.RegionGroupId.nth sg.regions_hierarchy gid in - let parents = - List.fold_left - (fun s gid -> - (* Compute the parents *) - let parents = list_parent_region_groups sg gid in - (* Parents U current region *) - let parents = T.RegionGroupId.Set.add gid parents in - (* Make the union with the accumulator *) - T.RegionGroupId.Set.union s parents) - T.RegionGroupId.Set.empty rg.parents - in - parents - -(** Small utility: same as {!list_parent_region_groups}, but returns an ordered list. *) -let list_ordered_parent_region_groups (sg : fun_sig) (gid : T.RegionGroupId.id) - : T.RegionGroupId.id list = - let pset = list_parent_region_groups sg gid in - let parents = - List.filter - (fun (rg : T.region_var_group) -> T.RegionGroupId.Set.mem rg.id pset) - sg.regions_hierarchy - in - let parents = List.map (fun (rg : T.region_var_group) -> rg.id) parents in - parents - -let fun_body_get_input_vars (fbody : fun_body) : var list = - let locals = List.tl fbody.locals in - Collections.List.prefix fbody.arg_count locals diff --git a/src/LlbcOfJson.ml b/src/LlbcOfJson.ml deleted file mode 100644 index 79c9b756..00000000 --- a/src/LlbcOfJson.ml +++ /dev/null @@ -1,915 +0,0 @@ -(** Functions to load LLBC ASTs from json. - - Initially, we used [ppx_derive_yojson] to automate this. - However, [ppx_derive_yojson] expects formatting to be slightly - different from what [serde_rs] generates (because it uses [Yojson.Safe.t] - and not [Yojson.Basic.t]). - - TODO: we should check all that the integer values are in the proper range - *) - -open Yojson.Basic -open Names -open OfJsonBasic -open Identifiers -open Meta -module T = Types -module V = Values -module S = Scalars -module E = Expressions -module A = LlbcAst -module TU = TypesUtils -module AU = LlbcAstUtils -module LocalFileId = IdGen () -module VirtualFileId = IdGen () - -(** The default logger *) -let log = Logging.llbc_of_json_logger - -(** A file identifier *) -type file_id = LocalId of LocalFileId.id | VirtualId of VirtualFileId.id -[@@deriving show, ord] - -module OrderedIdToFile : Collections.OrderedType with type t = file_id = struct - type t = file_id - - let compare fid0 fid1 = compare_file_id fid0 fid1 - - let to_string id = - match id with - | LocalId id -> "Local " ^ LocalFileId.to_string id - | VirtualId id -> "Virtual " ^ VirtualFileId.to_string id - - let pp_t fmt x = Format.pp_print_string fmt (to_string x) - let show_t x = to_string x -end - -module IdToFile = Collections.MakeMap (OrderedIdToFile) - -type id_to_file_map = file_name IdToFile.t - -let file_id_of_json (js : json) : (file_id, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc [ ("LocalId", id) ] -> - let* id = LocalFileId.id_of_json id in - Ok (LocalId id) - | `Assoc [ ("VirtualId", id) ] -> - let* id = VirtualFileId.id_of_json id in - Ok (VirtualId id) - | _ -> Error "") - -let file_name_of_json (js : json) : (file_name, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc [ ("Virtual", name) ] -> - let* name = string_of_json name in - Ok (Virtual name) - | `Assoc [ ("Local", name) ] -> - let* name = string_of_json name in - Ok (Local name) - | _ -> Error "") - -(** Deserialize a map from file id to file name. - - In the serialized LLBC, the files in the loc spans are refered to by their - ids, in order to save space. In a functional language like OCaml this is - not necessary: we thus replace the file ids by the file name themselves in - the AST. - The "id to file" map is thus only used in the deserialization process. - *) -let id_to_file_of_json (js : json) : (id_to_file_map, string) result = - combine_error_msgs js __FUNCTION__ - ((* The map is stored as a list of pairs (key, value): we deserialize - * this list then convert it to a map *) - let* key_values = - list_of_json (pair_of_json file_id_of_json file_name_of_json) js - in - Ok (IdToFile.of_list key_values)) - -let loc_of_json (js : json) : (loc, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc [ ("line", line); ("col", col) ] -> - let* line = int_of_json line in - let* col = int_of_json col in - Ok { line; col } - | _ -> Error "") - -let span_of_json (id_to_file : id_to_file_map) (js : json) : - (span, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc [ ("file_id", file_id); ("beg", beg_loc); ("end", end_loc) ] -> - let* file_id = file_id_of_json file_id in - let file = IdToFile.find file_id id_to_file in - let* beg_loc = loc_of_json beg_loc in - let* end_loc = loc_of_json end_loc in - Ok { file; beg_loc; end_loc } - | _ -> Error "") - -let meta_of_json (id_to_file : id_to_file_map) (js : json) : - (meta, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc [ ("span", span); ("generated_from_span", generated_from_span) ] -> - let* span = span_of_json id_to_file span in - let* generated_from_span = - option_of_json (span_of_json id_to_file) generated_from_span - in - Ok { span; generated_from_span } - | _ -> Error "") - -let path_elem_of_json (js : json) : (path_elem, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc [ ("Ident", name) ] -> - let* name = string_of_json name in - Ok (Ident name) - | `Assoc [ ("Disambiguator", d) ] -> - let* d = Disambiguator.id_of_json d in - Ok (Disambiguator d) - | _ -> Error "") - -let name_of_json (js : json) : (name, string) result = - combine_error_msgs js __FUNCTION__ (list_of_json path_elem_of_json js) - -let fun_name_of_json (js : json) : (fun_name, string) result = - combine_error_msgs js __FUNCTION__ (name_of_json js) - -let type_var_of_json (js : json) : (T.type_var, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc [ ("index", index); ("name", name) ] -> - let* index = T.TypeVarId.id_of_json index in - let* name = string_of_json name in - Ok { T.index; name } - | _ -> Error "") - -let region_var_of_json (js : json) : (T.region_var, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc [ ("index", index); ("name", name) ] -> - let* index = T.RegionVarId.id_of_json index in - let* name = string_option_of_json name in - Ok { T.index; name } - | _ -> Error "") - -let region_of_json (js : json) : (T.RegionVarId.id T.region, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `String "Static" -> Ok T.Static - | `Assoc [ ("Var", rid) ] -> - let* rid = T.RegionVarId.id_of_json rid in - Ok (T.Var rid) - | _ -> Error "") - -let erased_region_of_json (js : json) : (T.erased_region, string) result = - combine_error_msgs js __FUNCTION__ - (match js with `String "Erased" -> Ok T.Erased | _ -> Error "") - -let integer_type_of_json (js : json) : (T.integer_type, string) result = - match js with - | `String "Isize" -> Ok T.Isize - | `String "I8" -> Ok T.I8 - | `String "I16" -> Ok T.I16 - | `String "I32" -> Ok T.I32 - | `String "I64" -> Ok T.I64 - | `String "I128" -> Ok T.I128 - | `String "Usize" -> Ok T.Usize - | `String "U8" -> Ok T.U8 - | `String "U16" -> Ok T.U16 - | `String "U32" -> Ok T.U32 - | `String "U64" -> Ok T.U64 - | `String "U128" -> Ok T.U128 - | _ -> Error ("integer_type_of_json failed on: " ^ show js) - -let ref_kind_of_json (js : json) : (T.ref_kind, string) result = - match js with - | `String "Mut" -> Ok T.Mut - | `String "Shared" -> Ok T.Shared - | _ -> Error ("ref_kind_of_json failed on: " ^ show js) - -let assumed_ty_of_json (js : json) : (T.assumed_ty, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `String "Box" -> Ok T.Box - | `String "Vec" -> Ok T.Vec - | `String "Option" -> Ok T.Option - | _ -> Error "") - -let type_id_of_json (js : json) : (T.type_id, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc [ ("Adt", id) ] -> - let* id = T.TypeDeclId.id_of_json id in - Ok (T.AdtId id) - | `String "Tuple" -> Ok T.Tuple - | `Assoc [ ("Assumed", aty) ] -> - let* aty = assumed_ty_of_json aty in - Ok (T.Assumed aty) - | _ -> Error "") - -let rec ty_of_json (r_of_json : json -> ('r, string) result) (js : json) : - ('r T.ty, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc [ ("Adt", `List [ id; regions; types ]) ] -> - let* id = type_id_of_json id in - let* regions = list_of_json r_of_json regions in - let* types = list_of_json (ty_of_json r_of_json) types in - (* Sanity check *) - (match id with T.Tuple -> assert (List.length regions = 0) | _ -> ()); - Ok (T.Adt (id, regions, types)) - | `Assoc [ ("TypeVar", `List [ id ]) ] -> - let* id = T.TypeVarId.id_of_json id in - Ok (T.TypeVar id) - | `String "Bool" -> Ok Bool - | `String "Char" -> Ok Char - | `String "`Never" -> Ok Never - | `Assoc [ ("Integer", `List [ int_ty ]) ] -> - let* int_ty = integer_type_of_json int_ty in - Ok (T.Integer int_ty) - | `String "Str" -> Ok Str - | `Assoc [ ("Array", `List [ ty ]) ] -> - let* ty = ty_of_json r_of_json ty in - Ok (T.Array ty) - | `Assoc [ ("Slice", `List [ ty ]) ] -> - let* ty = ty_of_json r_of_json ty in - Ok (T.Slice ty) - | `Assoc [ ("Ref", `List [ region; ty; ref_kind ]) ] -> - let* region = r_of_json region in - let* ty = ty_of_json r_of_json ty in - let* ref_kind = ref_kind_of_json ref_kind in - Ok (T.Ref (region, ty, ref_kind)) - | _ -> Error "") - -let sty_of_json (js : json) : (T.sty, string) result = - combine_error_msgs js __FUNCTION__ (ty_of_json region_of_json js) - -let ety_of_json (js : json) : (T.ety, string) result = - combine_error_msgs js __FUNCTION__ (ty_of_json erased_region_of_json js) - -let field_of_json (id_to_file : id_to_file_map) (js : json) : - (T.field, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc [ ("meta", meta); ("name", name); ("ty", ty) ] -> - let* meta = meta_of_json id_to_file meta in - let* name = option_of_json string_of_json name in - let* ty = sty_of_json ty in - Ok { T.meta; field_name = name; field_ty = ty } - | _ -> Error "") - -let variant_of_json (id_to_file : id_to_file_map) (js : json) : - (T.variant, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc [ ("meta", meta); ("name", name); ("fields", fields) ] -> - let* meta = meta_of_json id_to_file meta in - let* name = string_of_json name in - let* fields = list_of_json (field_of_json id_to_file) fields in - Ok { T.meta; variant_name = name; fields } - | _ -> Error "") - -let type_decl_kind_of_json (id_to_file : id_to_file_map) (js : json) : - (T.type_decl_kind, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc [ ("Struct", fields) ] -> - let* fields = list_of_json (field_of_json id_to_file) fields in - Ok (T.Struct fields) - | `Assoc [ ("Enum", variants) ] -> - let* variants = list_of_json (variant_of_json id_to_file) variants in - Ok (T.Enum variants) - | `String "Opaque" -> Ok T.Opaque - | _ -> Error "") - -let region_var_group_of_json (js : json) : (T.region_var_group, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc [ ("id", id); ("regions", regions); ("parents", parents) ] -> - let* id = T.RegionGroupId.id_of_json id in - let* regions = list_of_json T.RegionVarId.id_of_json regions in - let* parents = list_of_json T.RegionGroupId.id_of_json parents in - Ok { T.id; regions; parents } - | _ -> Error "") - -let region_var_groups_of_json (js : json) : (T.region_var_groups, string) result - = - combine_error_msgs js __FUNCTION__ (list_of_json region_var_group_of_json js) - -let type_decl_of_json (id_to_file : id_to_file_map) (js : json) : - (T.type_decl, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc - [ - ("def_id", def_id); - ("meta", meta); - ("name", name); - ("region_params", region_params); - ("type_params", type_params); - ("regions_hierarchy", regions_hierarchy); - ("kind", kind); - ] -> - let* def_id = T.TypeDeclId.id_of_json def_id in - let* meta = meta_of_json id_to_file meta in - let* name = name_of_json name in - let* region_params = list_of_json region_var_of_json region_params in - let* type_params = list_of_json type_var_of_json type_params in - let* kind = type_decl_kind_of_json id_to_file kind in - let* regions_hierarchy = region_var_groups_of_json regions_hierarchy in - Ok - { - T.def_id; - meta; - name; - region_params; - type_params; - kind; - regions_hierarchy; - } - | _ -> Error "") - -let var_of_json (js : json) : (A.var, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc [ ("index", index); ("name", name); ("ty", ty) ] -> - let* index = V.VarId.id_of_json index in - let* name = string_option_of_json name in - let* var_ty = ety_of_json ty in - Ok { A.index; name; var_ty } - | _ -> Error "") - -let big_int_of_json (js : json) : (V.big_int, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Int i -> Ok (Z.of_int i) - | `String is -> Ok (Z.of_string is) - | _ -> Error "") - -(** Deserialize a {!V.scalar_value} from JSON and **check the ranges**. - - Note that in practice we also check that the values are in range - in the interpreter functions. Still, it doesn't cost much to be - a bit conservative. - *) -let scalar_value_of_json (js : json) : (V.scalar_value, string) result = - let res = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc [ ("Isize", `List [ bi ]) ] -> - let* bi = big_int_of_json bi in - Ok { V.value = bi; int_ty = Isize } - | `Assoc [ ("I8", `List [ bi ]) ] -> - let* bi = big_int_of_json bi in - Ok { V.value = bi; int_ty = I8 } - | `Assoc [ ("I16", `List [ bi ]) ] -> - let* bi = big_int_of_json bi in - Ok { V.value = bi; int_ty = I16 } - | `Assoc [ ("I32", `List [ bi ]) ] -> - let* bi = big_int_of_json bi in - Ok { V.value = bi; int_ty = I32 } - | `Assoc [ ("I64", `List [ bi ]) ] -> - let* bi = big_int_of_json bi in - Ok { V.value = bi; int_ty = I64 } - | `Assoc [ ("I128", `List [ bi ]) ] -> - let* bi = big_int_of_json bi in - Ok { V.value = bi; int_ty = I128 } - | `Assoc [ ("Usize", `List [ bi ]) ] -> - let* bi = big_int_of_json bi in - Ok { V.value = bi; int_ty = Usize } - | `Assoc [ ("U8", `List [ bi ]) ] -> - let* bi = big_int_of_json bi in - Ok { V.value = bi; int_ty = U8 } - | `Assoc [ ("U16", `List [ bi ]) ] -> - let* bi = big_int_of_json bi in - Ok { V.value = bi; int_ty = U16 } - | `Assoc [ ("U32", `List [ bi ]) ] -> - let* bi = big_int_of_json bi in - Ok { V.value = bi; int_ty = U32 } - | `Assoc [ ("U64", `List [ bi ]) ] -> - let* bi = big_int_of_json bi in - Ok { V.value = bi; int_ty = U64 } - | `Assoc [ ("U128", `List [ bi ]) ] -> - let* bi = big_int_of_json bi in - Ok { V.value = bi; int_ty = U128 } - | _ -> Error "") - in - match res with - | Error _ -> res - | Ok sv -> - if not (S.check_scalar_value_in_range sv) then ( - log#serror ("Scalar value not in range: " ^ V.show_scalar_value sv); - raise (Failure ("Scalar value not in range: " ^ V.show_scalar_value sv))); - res - -let field_proj_kind_of_json (js : json) : (E.field_proj_kind, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc [ ("ProjAdt", `List [ def_id; opt_variant_id ]) ] -> - let* def_id = T.TypeDeclId.id_of_json def_id in - let* opt_variant_id = - option_of_json T.VariantId.id_of_json opt_variant_id - in - Ok (E.ProjAdt (def_id, opt_variant_id)) - | `Assoc [ ("ProjTuple", i) ] -> - let* i = int_of_json i in - Ok (E.ProjTuple i) - | `Assoc [ ("ProjOption", variant_id) ] -> - let* variant_id = T.VariantId.id_of_json variant_id in - Ok (E.ProjOption variant_id) - | _ -> Error "") - -let projection_elem_of_json (js : json) : (E.projection_elem, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `String "Deref" -> Ok E.Deref - | `String "DerefBox" -> Ok E.DerefBox - | `Assoc [ ("Field", `List [ proj_kind; field_id ]) ] -> - let* proj_kind = field_proj_kind_of_json proj_kind in - let* field_id = T.FieldId.id_of_json field_id in - Ok (E.Field (proj_kind, field_id)) - | _ -> Error ("projection_elem_of_json failed on:" ^ show js)) - -let projection_of_json (js : json) : (E.projection, string) result = - combine_error_msgs js __FUNCTION__ (list_of_json projection_elem_of_json js) - -let place_of_json (js : json) : (E.place, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc [ ("var_id", var_id); ("projection", projection) ] -> - let* var_id = V.VarId.id_of_json var_id in - let* projection = projection_of_json projection in - Ok { E.var_id; projection } - | _ -> Error "") - -let borrow_kind_of_json (js : json) : (E.borrow_kind, string) result = - match js with - | `String "Shared" -> Ok E.Shared - | `String "Mut" -> Ok E.Mut - | `String "TwoPhaseMut" -> Ok E.TwoPhaseMut - | _ -> Error ("borrow_kind_of_json failed on:" ^ show js) - -let unop_of_json (js : json) : (E.unop, string) result = - match js with - | `String "Not" -> Ok E.Not - | `String "Neg" -> Ok E.Neg - | `Assoc [ ("Cast", `List [ src_ty; tgt_ty ]) ] -> - let* src_ty = integer_type_of_json src_ty in - let* tgt_ty = integer_type_of_json tgt_ty in - Ok (E.Cast (src_ty, tgt_ty)) - | _ -> Error ("unop_of_json failed on:" ^ show js) - -let binop_of_json (js : json) : (E.binop, string) result = - match js with - | `String "BitXor" -> Ok E.BitXor - | `String "BitAnd" -> Ok E.BitAnd - | `String "BitOr" -> Ok E.BitOr - | `String "Eq" -> Ok E.Eq - | `String "Lt" -> Ok E.Lt - | `String "Le" -> Ok E.Le - | `String "Ne" -> Ok E.Ne - | `String "Ge" -> Ok E.Ge - | `String "Gt" -> Ok E.Gt - | `String "Div" -> Ok E.Div - | `String "Rem" -> Ok E.Rem - | `String "Add" -> Ok E.Add - | `String "Sub" -> Ok E.Sub - | `String "Mul" -> Ok E.Mul - | `String "Shl" -> Ok E.Shl - | `String "Shr" -> Ok E.Shr - | _ -> Error ("binop_of_json failed on:" ^ show js) - -let constant_value_of_json (js : json) : (V.constant_value, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc [ ("Scalar", scalar_value) ] -> - let* scalar_value = scalar_value_of_json scalar_value in - Ok (V.Scalar scalar_value) - | `Assoc [ ("Bool", v) ] -> - let* v = bool_of_json v in - Ok (V.Bool v) - | `Assoc [ ("Char", v) ] -> - let* v = char_of_json v in - Ok (V.Char v) - | `Assoc [ ("String", v) ] -> - let* v = string_of_json v in - Ok (V.String v) - | _ -> Error "") - -let operand_of_json (js : json) : (E.operand, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc [ ("Copy", place) ] -> - let* place = place_of_json place in - Ok (E.Copy place) - | `Assoc [ ("Move", place) ] -> - let* place = place_of_json place in - Ok (E.Move place) - | `Assoc [ ("Const", `List [ ty; cv ]) ] -> - let* ty = ety_of_json ty in - let* cv = constant_value_of_json cv in - Ok (E.Constant (ty, cv)) - | _ -> Error "") - -let aggregate_kind_of_json (js : json) : (E.aggregate_kind, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `String "AggregatedTuple" -> Ok E.AggregatedTuple - | `Assoc [ ("AggregatedOption", `List [ variant_id; ty ]) ] -> - let* variant_id = T.VariantId.id_of_json variant_id in - let* ty = ety_of_json ty in - Ok (E.AggregatedOption (variant_id, ty)) - | `Assoc [ ("AggregatedAdt", `List [ id; opt_variant_id; regions; tys ]) ] - -> - let* id = T.TypeDeclId.id_of_json id in - let* opt_variant_id = - option_of_json T.VariantId.id_of_json opt_variant_id - in - let* regions = list_of_json erased_region_of_json regions in - let* tys = list_of_json ety_of_json tys in - Ok (E.AggregatedAdt (id, opt_variant_id, regions, tys)) - | _ -> Error "") - -let rvalue_of_json (js : json) : (E.rvalue, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc [ ("Use", op) ] -> - let* op = operand_of_json op in - Ok (E.Use op) - | `Assoc [ ("Ref", `List [ place; borrow_kind ]) ] -> - let* place = place_of_json place in - let* borrow_kind = borrow_kind_of_json borrow_kind in - Ok (E.Ref (place, borrow_kind)) - | `Assoc [ ("UnaryOp", `List [ unop; op ]) ] -> - let* unop = unop_of_json unop in - let* op = operand_of_json op in - Ok (E.UnaryOp (unop, op)) - | `Assoc [ ("BinaryOp", `List [ binop; op1; op2 ]) ] -> - let* binop = binop_of_json binop in - let* op1 = operand_of_json op1 in - let* op2 = operand_of_json op2 in - Ok (E.BinaryOp (binop, op1, op2)) - | `Assoc [ ("Discriminant", place) ] -> - let* place = place_of_json place in - Ok (E.Discriminant place) - | `Assoc [ ("Aggregate", `List [ aggregate_kind; ops ]) ] -> - let* aggregate_kind = aggregate_kind_of_json aggregate_kind in - let* ops = list_of_json operand_of_json ops in - Ok (E.Aggregate (aggregate_kind, ops)) - | _ -> Error "") - -let assumed_fun_id_of_json (js : json) : (A.assumed_fun_id, string) result = - match js with - | `String "Replace" -> Ok A.Replace - | `String "BoxNew" -> Ok A.BoxNew - | `String "BoxDeref" -> Ok A.BoxDeref - | `String "BoxDerefMut" -> Ok A.BoxDerefMut - | `String "BoxFree" -> Ok A.BoxFree - | `String "VecNew" -> Ok A.VecNew - | `String "VecPush" -> Ok A.VecPush - | `String "VecInsert" -> Ok A.VecInsert - | `String "VecLen" -> Ok A.VecLen - | `String "VecIndex" -> Ok A.VecIndex - | `String "VecIndexMut" -> Ok A.VecIndexMut - | _ -> Error ("assumed_fun_id_of_json failed on:" ^ show js) - -let fun_id_of_json (js : json) : (A.fun_id, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc [ ("Regular", id) ] -> - let* id = A.FunDeclId.id_of_json id in - Ok (A.Regular id) - | `Assoc [ ("Assumed", fid) ] -> - let* fid = assumed_fun_id_of_json fid in - Ok (A.Assumed fid) - | _ -> Error "") - -let assertion_of_json (js : json) : (A.assertion, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc [ ("cond", cond); ("expected", expected) ] -> - let* cond = operand_of_json cond in - let* expected = bool_of_json expected in - Ok { A.cond; expected } - | _ -> Error "") - -let fun_sig_of_json (js : json) : (A.fun_sig, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc - [ - ("region_params", region_params); - ("num_early_bound_regions", num_early_bound_regions); - ("regions_hierarchy", regions_hierarchy); - ("type_params", type_params); - ("inputs", inputs); - ("output", output); - ] -> - let* region_params = list_of_json region_var_of_json region_params in - let* num_early_bound_regions = int_of_json num_early_bound_regions in - let* regions_hierarchy = region_var_groups_of_json regions_hierarchy in - let* type_params = list_of_json type_var_of_json type_params in - let* inputs = list_of_json sty_of_json inputs in - let* output = sty_of_json output in - Ok - { - A.region_params; - num_early_bound_regions; - regions_hierarchy; - type_params; - inputs; - output; - } - | _ -> Error "") - -let call_of_json (js : json) : (A.call, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc - [ - ("func", func); - ("region_args", region_args); - ("type_args", type_args); - ("args", args); - ("dest", dest); - ] -> - let* func = fun_id_of_json func in - let* region_args = list_of_json erased_region_of_json region_args in - let* type_args = list_of_json ety_of_json type_args in - let* args = list_of_json operand_of_json args in - let* dest = place_of_json dest in - Ok { A.func; region_args; type_args; args; dest } - | _ -> Error "") - -let rec statement_of_json (id_to_file : id_to_file_map) (js : json) : - (A.statement, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc [ ("meta", meta); ("content", content) ] -> - let* meta = meta_of_json id_to_file meta in - let* content = raw_statement_of_json id_to_file content in - Ok { A.meta; content } - | _ -> Error "") - -and raw_statement_of_json (id_to_file : id_to_file_map) (js : json) : - (A.raw_statement, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc [ ("Assign", `List [ place; rvalue ]) ] -> - let* place = place_of_json place in - let* rvalue = rvalue_of_json rvalue in - Ok (A.Assign (place, rvalue)) - | `Assoc [ ("AssignGlobal", `List [ dst; global ]) ] -> - let* dst = V.VarId.id_of_json dst in - let* global = A.GlobalDeclId.id_of_json global in - Ok (A.AssignGlobal { dst; global }) - | `Assoc [ ("FakeRead", place) ] -> - let* place = place_of_json place in - Ok (A.FakeRead place) - | `Assoc [ ("SetDiscriminant", `List [ place; variant_id ]) ] -> - let* place = place_of_json place in - let* variant_id = T.VariantId.id_of_json variant_id in - Ok (A.SetDiscriminant (place, variant_id)) - | `Assoc [ ("Drop", place) ] -> - let* place = place_of_json place in - Ok (A.Drop place) - | `Assoc [ ("Assert", assertion) ] -> - let* assertion = assertion_of_json assertion in - Ok (A.Assert assertion) - | `Assoc [ ("Call", call) ] -> - let* call = call_of_json call in - Ok (A.Call call) - | `String "Panic" -> Ok A.Panic - | `String "Return" -> Ok A.Return - | `Assoc [ ("Break", i) ] -> - let* i = int_of_json i in - Ok (A.Break i) - | `Assoc [ ("Continue", i) ] -> - let* i = int_of_json i in - Ok (A.Continue i) - | `String "Nop" -> Ok A.Nop - | `Assoc [ ("Sequence", `List [ st1; st2 ]) ] -> - let* st1 = statement_of_json id_to_file st1 in - let* st2 = statement_of_json id_to_file st2 in - Ok (A.Sequence (st1, st2)) - | `Assoc [ ("Switch", `List [ op; tgt ]) ] -> - let* op = operand_of_json op in - let* tgt = switch_targets_of_json id_to_file tgt in - Ok (A.Switch (op, tgt)) - | `Assoc [ ("Loop", st) ] -> - let* st = statement_of_json id_to_file st in - Ok (A.Loop st) - | _ -> Error "") - -and switch_targets_of_json (id_to_file : id_to_file_map) (js : json) : - (A.switch_targets, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc [ ("If", `List [ st1; st2 ]) ] -> - let* st1 = statement_of_json id_to_file st1 in - let* st2 = statement_of_json id_to_file st2 in - Ok (A.If (st1, st2)) - | `Assoc [ ("SwitchInt", `List [ int_ty; tgts; otherwise ]) ] -> - let* int_ty = integer_type_of_json int_ty in - let* tgts = - list_of_json - (pair_of_json - (list_of_json scalar_value_of_json) - (statement_of_json id_to_file)) - tgts - in - let* otherwise = statement_of_json id_to_file otherwise in - Ok (A.SwitchInt (int_ty, tgts, otherwise)) - | _ -> Error "") - -let fun_body_of_json (id_to_file : id_to_file_map) (js : json) : - (A.fun_body, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc - [ - ("meta", meta); - ("arg_count", arg_count); - ("locals", locals); - ("body", body); - ] -> - let* meta = meta_of_json id_to_file meta in - let* arg_count = int_of_json arg_count in - let* locals = list_of_json var_of_json locals in - let* body = statement_of_json id_to_file body in - Ok { A.meta; arg_count; locals; body } - | _ -> Error "") - -let fun_decl_of_json (id_to_file : id_to_file_map) (js : json) : - (A.fun_decl, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc - [ - ("def_id", def_id); - ("meta", meta); - ("name", name); - ("signature", signature); - ("body", body); - ] -> - let* def_id = A.FunDeclId.id_of_json def_id in - let* meta = meta_of_json id_to_file meta in - let* name = fun_name_of_json name in - let* signature = fun_sig_of_json signature in - let* body = option_of_json (fun_body_of_json id_to_file) body in - Ok - { A.def_id; meta; name; signature; body; is_global_decl_body = false } - | _ -> Error "") - -(* Strict type for the number of function declarations (see {!global_to_fun_id} below) *) -type global_id_converter = { fun_count : int } [@@deriving show] - -(** Converts a global id to its corresponding function id. - To do so, it adds the global id to the number of function declarations : - We have the bijection [global_fun_id <=> global_id + fun_id_count]. -*) -let global_to_fun_id (conv : global_id_converter) (gid : A.GlobalDeclId.id) : - A.FunDeclId.id = - A.FunDeclId.of_int (A.GlobalDeclId.to_int gid + conv.fun_count) - -(* Converts a global declaration to a function declaration. - *) -let global_decl_of_json (id_to_file : id_to_file_map) (js : json) - (gid_conv : global_id_converter) : - (A.global_decl * A.fun_decl, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc - [ - ("def_id", def_id); - ("meta", meta); - ("name", name); - ("ty", ty); - ("body", body); - ] -> - let* global_id = A.GlobalDeclId.id_of_json def_id in - let fun_id = global_to_fun_id gid_conv global_id in - let* meta = meta_of_json id_to_file meta in - let* name = fun_name_of_json name in - let* ty = ety_of_json ty in - let* body = option_of_json (fun_body_of_json id_to_file) body in - let signature : A.fun_sig = - { - region_params = []; - num_early_bound_regions = 0; - regions_hierarchy = []; - type_params = []; - inputs = []; - output = TU.ety_no_regions_to_sty ty; - } - in - Ok - ( { A.def_id = global_id; meta; body_id = fun_id; name; ty }, - { - A.def_id = fun_id; - meta; - name; - signature; - body; - is_global_decl_body = true; - } ) - | _ -> Error "") - -let g_declaration_group_of_json (id_of_json : json -> ('id, string) result) - (js : json) : ('id Crates.g_declaration_group, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc [ ("NonRec", `List [ id ]) ] -> - let* id = id_of_json id in - Ok (Crates.NonRec id) - | `Assoc [ ("Rec", `List [ ids ]) ] -> - let* ids = list_of_json id_of_json ids in - Ok (Crates.Rec ids) - | _ -> Error "") - -let type_declaration_group_of_json (js : json) : - (Crates.type_declaration_group, string) result = - combine_error_msgs js __FUNCTION__ - (g_declaration_group_of_json T.TypeDeclId.id_of_json js) - -let fun_declaration_group_of_json (js : json) : - (Crates.fun_declaration_group, string) result = - combine_error_msgs js __FUNCTION__ - (g_declaration_group_of_json A.FunDeclId.id_of_json js) - -let global_declaration_group_of_json (js : json) : - (A.GlobalDeclId.id, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc [ ("NonRec", `List [ id ]) ] -> - let* id = A.GlobalDeclId.id_of_json id in - Ok id - | `Assoc [ ("Rec", `List [ _ ]) ] -> Error "got mutually dependent globals" - | _ -> Error "") - -let declaration_group_of_json (js : json) : - (Crates.declaration_group, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc [ ("Type", `List [ decl ]) ] -> - let* decl = type_declaration_group_of_json decl in - Ok (Crates.Type decl) - | `Assoc [ ("Fun", `List [ decl ]) ] -> - let* decl = fun_declaration_group_of_json decl in - Ok (Crates.Fun decl) - | `Assoc [ ("Global", `List [ decl ]) ] -> - let* id = global_declaration_group_of_json decl in - Ok (Crates.Global id) - | _ -> Error "") - -let length_of_json_list (js : json) : (int, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `List jsl -> Ok (List.length jsl) - | _ -> Error ("not a list: " ^ show js)) - -let llbc_crate_of_json (js : json) : (Crates.llbc_crate, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc - [ - ("name", name); - ("id_to_file", id_to_file); - ("declarations", declarations); - ("types", types); - ("functions", functions); - ("globals", globals); - ] -> - (* We first deserialize the declaration groups (which simply contain ids) - * and all the declarations *butù* the globals *) - let* name = string_of_json name in - let* id_to_file = id_to_file_of_json id_to_file in - let* declarations = - list_of_json declaration_group_of_json declarations - in - let* types = list_of_json (type_decl_of_json id_to_file) types in - let* functions = list_of_json (fun_decl_of_json id_to_file) functions in - (* When deserializing the globals, we split the global declarations - * between the globals themselves and their bodies, which are simply - * functions with no arguments. We add the global bodies to the list - * of function declarations: the (fresh) ids we use for those bodies - * are simply given by: [num_functions + global_id] *) - let gid_conv = { fun_count = List.length functions } in - let* globals = - list_of_json - (fun js -> global_decl_of_json id_to_file js gid_conv) - globals - in - let globals, global_bodies = List.split globals in - Ok - { - Crates.name; - declarations; - types; - functions = functions @ global_bodies; - globals; - } - | _ -> Error "") diff --git a/src/Logging.ml b/src/Logging.ml deleted file mode 100644 index e83f25f8..00000000 --- a/src/Logging.ml +++ /dev/null @@ -1,179 +0,0 @@ -module H = Easy_logging.Handlers -module L = Easy_logging.Logging - -let _ = L.make_logger "MainLogger" Debug [ Cli Debug ] - -(** The main logger *) -let main_log = L.get_logger "MainLogger" - -(** Below, we create subgloggers for various submodules, so that we can precisely - toggle logging on/off, depending on which information we need *) - -(** Logger for LlbcOfJson *) -let llbc_of_json_logger = L.get_logger "MainLogger.LlbcOfJson" - -(** Logger for PrePasses *) -let pre_passes_log = L.get_logger "MainLogger.PrePasses" - -(** Logger for Translate *) -let translate_log = L.get_logger "MainLogger.Translate" - -(** Logger for PureUtils *) -let pure_utils_log = L.get_logger "MainLogger.PureUtils" - -(** Logger for SymbolicToPure *) -let symbolic_to_pure_log = L.get_logger "MainLogger.SymbolicToPure" - -(** Logger for PureMicroPasses *) -let pure_micro_passes_log = L.get_logger "MainLogger.PureMicroPasses" - -(** Logger for PureToExtract *) -let pure_to_extract_log = L.get_logger "MainLogger.PureToExtract" - -(** Logger for Interpreter *) -let interpreter_log = L.get_logger "MainLogger.Interpreter" - -(** Logger for InterpreterStatements *) -let statements_log = L.get_logger "MainLogger.Interpreter.Statements" - -(** Logger for InterpreterExpressions *) -let expressions_log = L.get_logger "MainLogger.Interpreter.Expressions" - -(** Logger for InterpreterPaths *) -let paths_log = L.get_logger "MainLogger.Interpreter.Paths" - -(** Logger for InterpreterExpansion *) -let expansion_log = L.get_logger "MainLogger.Interpreter.Expansion" - -(** Logger for InterpreterBorrows *) -let borrows_log = L.get_logger "MainLogger.Interpreter.Borrows" - -(** Logger for Invariants *) -let invariants_log = L.get_logger "MainLogger.Interpreter.Invariants" - -(** Terminal colors - TODO: comes from easy_logging (did not manage to reuse the module directly) *) -type color = - | Default - | Black - | Red - | Green - | Yellow - | Blue - | Magenta - | Cyan - | Gray - | White - | LRed - | LGreen - | LYellow - | LBlue - | LMagenta - | LCyan - | LGray - -(** Terminal styles - TODO: comes from easy_logging (did not manage to reuse the module directly) *) -type format = Bold | Underline | Invert | Fg of color | Bg of color - -(** TODO: comes from easy_logging (did not manage to reuse the module directly) *) -let to_fg_code c = - match c with - | Default -> 39 - | Black -> 30 - | Red -> 31 - | Green -> 32 - | Yellow -> 33 - | Blue -> 34 - | Magenta -> 35 - | Cyan -> 36 - | Gray -> 90 - | White -> 97 - | LRed -> 91 - | LGreen -> 92 - | LYellow -> 93 - | LBlue -> 94 - | LMagenta -> 95 - | LCyan -> 96 - | LGray -> 37 - -(** TODO: comes from easy_logging (did not manage to reuse the module directly) *) -let to_bg_code c = - match c with - | Default -> 49 - | Black -> 40 - | Red -> 41 - | Green -> 42 - | Yellow -> 43 - | Blue -> 44 - | Magenta -> 45 - | Cyan -> 46 - | Gray -> 100 - | White -> 107 - | LRed -> 101 - | LGreen -> 102 - | LYellow -> 103 - | LBlue -> 104 - | LMagenta -> 105 - | LCyan -> 106 - | LGray -> 47 - -(** TODO: comes from easy_logging (did not manage to reuse the module directly) *) -let style_to_codes s = - match s with - | Bold -> (1, 21) - | Underline -> (4, 24) - | Invert -> (7, 27) - | Fg c -> (to_fg_code c, to_fg_code Default) - | Bg c -> (to_bg_code c, to_bg_code Default) - -(** TODO: comes from easy_logging (did not manage to reuse the module directly) - I made a minor modifications, though. *) -let level_to_color (lvl : L.level) = - match lvl with - | L.Flash -> LMagenta - | Error -> LRed - | Warning -> LYellow - | Info -> LGreen - | Trace -> Cyan - | Debug -> LBlue - | NoLevel -> Default - -(** [format styles str] formats [str] to the given [styles] - - TODO: comes from {{: http://ocamlverse.net/content/documentation_guidelines.html}[easy_logging]} - (did not manage to reuse the module directly) -*) -let rec format styles str = - match styles with - | (_ as s) :: styles' -> - let set, reset = style_to_codes s in - Printf.sprintf "\027[%dm%s\027[%dm" set (format styles' str) reset - | [] -> str - -(** TODO: comes from {{: http://ocamlverse.net/content/documentation_guidelines.html}[easy_logging]} - (did not manage to reuse the module directly) *) -let format_tags (tags : string list) = - match tags with - | [] -> "" - | _ -> - let elems_str = String.concat " | " tags in - "[" ^ elems_str ^ "] " - -(* Change the formatters *) -let main_logger_handler = - (* TODO: comes from easy_logging *) - let formatter (item : L.log_item) : string = - let item_level_fmt = - format [ Fg (level_to_color item.level) ] (L.show_level item.level) - and item_msg_fmt = - match item.level with - | Flash -> format [ Fg Black; Bg LMagenta ] item.msg - | _ -> item.msg - in - - Format.pp_set_max_indent Format.str_formatter 200; - Format.sprintf "@[[%-15s] %s%s@]" item_level_fmt (format_tags item.tags) - item_msg_fmt - in - (* There should be exactly one handler *) - let handlers = main_log#get_handlers in - List.iter (fun h -> H.set_formatter h formatter) handlers; - match handlers with [ handler ] -> handler | _ -> failwith "Unexpected" diff --git a/src/Meta.ml b/src/Meta.ml deleted file mode 100644 index f0e4ca04..00000000 --- a/src/Meta.ml +++ /dev/null @@ -1,44 +0,0 @@ -(** Meta data like code spans *) - -(** A line location *) -type loc = { - line : int; (** The (1-based) line number. *) - col : int; (** The (0-based) column offset. *) -} -[@@deriving show] - -type file_name = - | Virtual of string (** A remapped path (namely paths into stdlib) *) - | Local of string - (** A local path (a file coming from the current crate for instance) *) -[@@deriving show] - -(** Span data *) -type span = { file : file_name; beg_loc : loc; end_loc : loc } [@@deriving show] - -type meta = { - span : span; - (** The source code span. - - If this meta information is for a statement/terminator coming from a macro - expansion/inlining/etc., this span is (in case of macros) for the macro - before expansion (i.e., the location the code where the user wrote the call - to the macro). - - Ex: - {[ - // Below, we consider the spans for the statements inside `test` - - // the statement we consider, which gets inlined in `test` - VV - macro_rules! macro { ... st ... } // `generated_from_span` refers to this location - - fn test() { - macro!(); // <-- `span` refers to this location - } - ]} - *) - generated_from_span : span option; - (** Where the code actually comes from, in case of macro expansion/inlining/etc. *) -} -[@@deriving show] diff --git a/src/Names.ml b/src/Names.ml deleted file mode 100644 index a27db161..00000000 --- a/src/Names.ml +++ /dev/null @@ -1,80 +0,0 @@ -open Identifiers -module Disambiguator = IdGen () - -(** See the comments for [Name] *) -type path_elem = Ident of string | Disambiguator of Disambiguator.id -[@@deriving show, ord] - -(** A name such as: [std::collections::vector] (which would be represented as - [[Ident "std"; Ident "collections"; Ident "vector"]]) - - - A name really is a list of strings. However, we sometimes need to - introduce unique indices to disambiguate. This mostly happens because - of "impl" blocks in Rust: - {[ - impl List { - ... - } - ]} - - A type in Rust can have several "impl" blocks, and those blocks can - contain items with similar names. For this reason, we need to disambiguate - them with unique indices. Rustc calls those "disambiguators". In rustc, this - gives names like this: - - [betree_main::betree::NodeIdCounter{impl#0}::new] - - note that impl blocks can be nested, and macros sometimes generate - weird names (which require disambiguation): - [betree_main::betree_utils::_#1::{impl#0}::deserialize::{impl#0}] - - Finally, the paths used by rustc are a lot more precise and explicit than - those we expose in LLBC: for instance, every identifier belongs to a specific - namespace (value namespace, type namespace, etc.), and is coupled with a - disambiguator. - - On our side, we want to stay high-level and simple: we use string identifiers - as much as possible, insert disambiguators only when necessary (whenever - we find an "impl" block, typically) and check that the disambiguator is useless - in the other situations (i.e., the disambiguator is always equal to 0). - - Moreover, the items are uniquely disambiguated by their (integer) ids - ([TypeDeclId.id], etc.), and when extracting the code we have to deal with - name clashes anyway. Still, we might want to be more precise in the future. - - Also note that the first path element in the name is always the crate name. - *) -type name = path_elem list [@@deriving show, ord] - -let to_name (ls : string list) : name = List.map (fun s -> Ident s) ls - -type module_name = name [@@deriving show, ord] -type type_name = name [@@deriving show, ord] -type fun_name = name [@@deriving show, ord] -type global_name = name [@@deriving show, ord] - -(** Filter the disambiguators equal to 0 in a name *) -let filter_disambiguators_zero (n : name) : name = - let pred (pe : path_elem) : bool = - match pe with Ident _ -> true | Disambiguator d -> d <> Disambiguator.zero - in - List.filter pred n - -(** Filter the disambiguators in a name *) -let filter_disambiguators (n : name) : name = - let pred (pe : path_elem) : bool = - match pe with Ident _ -> true | Disambiguator _ -> false - in - List.filter pred n - -let as_ident (pe : path_elem) : string = - match pe with - | Ident s -> s - | Disambiguator _ -> raise (Failure "Improper variant") - -let path_elem_to_string (pe : path_elem) : string = - match pe with - | Ident s -> s - | Disambiguator d -> "{" ^ Disambiguator.to_string d ^ "}" - -let name_to_string (name : name) : string = - String.concat "::" (List.map path_elem_to_string name) diff --git a/src/OfJsonBasic.ml b/src/OfJsonBasic.ml deleted file mode 100644 index 07daf03d..00000000 --- a/src/OfJsonBasic.ml +++ /dev/null @@ -1,75 +0,0 @@ -(** This module defines various basic utilities for json deserialization. - - *) - -open Yojson.Basic - -type json = t - -let ( let* ) o f = match o with Error e -> Error e | Ok x -> f x - -let combine_error_msgs js msg res : ('a, string) result = - match res with - | Ok x -> Ok x - | Error e -> Error ("[" ^ msg ^ "]" ^ " failed on: " ^ show js ^ "\n\n" ^ e) - -let bool_of_json (js : json) : (bool, string) result = - match js with - | `Bool b -> Ok b - | _ -> Error ("bool_of_json: not a bool: " ^ show js) - -let int_of_json (js : json) : (int, string) result = - match js with - | `Int i -> Ok i - | _ -> Error ("int_of_json: not an int: " ^ show js) - -let char_of_json (js : json) : (char, string) result = - match js with - | `String c -> - if String.length c = 1 then Ok c.[0] - else Error ("char_of_json: stricly more than one character in: " ^ show js) - | _ -> Error ("char_of_json: not a char: " ^ show js) - -let rec of_json_list (a_of_json : json -> ('a, string) result) (jsl : json list) - : ('a list, string) result = - match jsl with - | [] -> Ok [] - | x :: jsl' -> - let* x = a_of_json x in - let* jsl' = of_json_list a_of_json jsl' in - Ok (x :: jsl') - -let pair_of_json (a_of_json : json -> ('a, string) result) - (b_of_json : json -> ('b, string) result) (js : json) : - ('a * 'b, string) result = - match js with - | `List [ a; b ] -> - let* a = a_of_json a in - let* b = b_of_json b in - Ok (a, b) - | _ -> Error ("pair_of_json failed on: " ^ show js) - -let list_of_json (a_of_json : json -> ('a, string) result) (js : json) : - ('a list, string) result = - combine_error_msgs js "list_of_json" - (match js with - | `List jsl -> of_json_list a_of_json jsl - | _ -> Error ("not a list: " ^ show js)) - -let string_of_json (js : json) : (string, string) result = - match js with - | `String str -> Ok str - | _ -> Error ("string_of_json: not a string: " ^ show js) - -let option_of_json (a_of_json : json -> ('a, string) result) (js : json) : - ('a option, string) result = - combine_error_msgs js "option_of_json" - (match js with - | `Null -> Ok None - | _ -> - let* x = a_of_json js in - Ok (Some x)) - -let string_option_of_json (js : json) : (string option, string) result = - combine_error_msgs js "string_option_of_json" - (option_of_json string_of_json js) diff --git a/src/PrePasses.ml b/src/PrePasses.ml deleted file mode 100644 index a09ae476..00000000 --- a/src/PrePasses.ml +++ /dev/null @@ -1,54 +0,0 @@ -(** This files contains passes we apply on the AST *before* calling the - (concrete/symbolic) interpreter on it - *) - -module T = Types -module V = Values -module E = Expressions -module C = Contexts -module A = LlbcAst -module L = Logging - -let log = L.pre_passes_log - -(** Rustc inserts a lot of drops before the assignments. - We consider those drops are part of the assignment, and splitting the - drop and the assignment is problematic for us because it can introduce - [⊥] under borrows. For instance, we encountered situations like the - following one: - - {[ - drop( *x ); // Illegal! Inserts a ⊥ under a borrow - *x = move ...; - ]} - - TODO: this is not necessary anymore - *) -let filter_drop_assigns (f : A.fun_decl) : A.fun_decl = - (* The visitor *) - let obj = - object (self) - inherit [_] A.map_statement as super - - method! visit_Sequence env st1 st2 = - match (st1.content, st2.content) with - | Drop p1, Assign (p2, _) -> - if p1 = p2 then (self#visit_statement env st2).content - else super#visit_Sequence env st1 st2 - | Drop p1, Sequence ({ content = Assign (p2, _); meta = _ }, _) -> - if p1 = p2 then (self#visit_statement env st2).content - else super#visit_Sequence env st1 st2 - | _ -> super#visit_Sequence env st1 st2 - end - in - (* Map *) - let body = - match f.body with - | Some body -> Some { body with body = obj#visit_statement () body.body } - | None -> None - in - { f with body } - -let apply_passes (m : Crates.llbc_crate) : Crates.llbc_crate = - let functions = List.map filter_drop_assigns m.functions in - { m with functions } diff --git a/src/Print.ml b/src/Print.ml deleted file mode 100644 index 03cab6ee..00000000 --- a/src/Print.ml +++ /dev/null @@ -1,1283 +0,0 @@ -open Names -module T = Types -module TU = TypesUtils -module V = Values -module VU = ValuesUtils -module E = Expressions -module A = LlbcAst -module C = Contexts - -let option_to_string (to_string : 'a -> string) (x : 'a option) : string = - match x with Some x -> "Some (" ^ to_string x ^ ")" | None -> "None" - -let name_to_string (name : name) : string = Names.name_to_string name -let fun_name_to_string (name : fun_name) : string = name_to_string name -let global_name_to_string (name : global_name) : string = name_to_string name - -(** Pretty-printing for types *) -module Types = struct - let type_var_to_string (tv : T.type_var) : string = tv.name - - let region_var_to_string (rv : T.region_var) : string = - match rv.name with - | Some name -> name - | None -> T.RegionVarId.to_string rv.index - - let region_var_id_to_string (rid : T.RegionVarId.id) : string = - "rv@" ^ T.RegionVarId.to_string rid - - let region_id_to_string (rid : T.RegionId.id) : string = - "r@" ^ T.RegionId.to_string rid - - let region_to_string (rid_to_string : 'rid -> string) (r : 'rid T.region) : - string = - match r with Static -> "'static" | Var rid -> rid_to_string rid - - let erased_region_to_string (_ : T.erased_region) : string = "'_" - - let ref_kind_to_string (rk : T.ref_kind) : string = - match rk with Mut -> "Mut" | Shared -> "Shared" - - let assumed_ty_to_string (_ : T.assumed_ty) : string = "Box" - - type 'r type_formatter = { - r_to_string : 'r -> string; - type_var_id_to_string : T.TypeVarId.id -> string; - type_decl_id_to_string : T.TypeDeclId.id -> string; - } - - type stype_formatter = T.RegionVarId.id T.region type_formatter - type rtype_formatter = T.RegionId.id T.region type_formatter - type etype_formatter = T.erased_region type_formatter - - let integer_type_to_string = function - | T.Isize -> "isize" - | T.I8 -> "i8" - | T.I16 -> "i16" - | T.I32 -> "i32" - | T.I64 -> "i64" - | T.I128 -> "i128" - | T.Usize -> "usize" - | T.U8 -> "u8" - | T.U16 -> "u16" - | T.U32 -> "u32" - | T.U64 -> "u64" - | T.U128 -> "u128" - - let type_id_to_string (fmt : 'r type_formatter) (id : T.type_id) : string = - match id with - | T.AdtId id -> fmt.type_decl_id_to_string id - | T.Tuple -> "" - | T.Assumed aty -> ( - match aty with - | Box -> "alloc::boxed::Box" - | Vec -> "alloc::vec::Vec" - | Option -> "core::option::Option") - - let rec ty_to_string (fmt : 'r type_formatter) (ty : 'r T.ty) : string = - match ty with - | T.Adt (id, regions, tys) -> - let is_tuple = match id with T.Tuple -> true | _ -> false in - let params = params_to_string fmt is_tuple regions tys in - type_id_to_string fmt id ^ params - | T.TypeVar tv -> fmt.type_var_id_to_string tv - | T.Bool -> "bool" - | T.Char -> "char" - | T.Never -> "⊥" - | T.Integer int_ty -> integer_type_to_string int_ty - | T.Str -> "str" - | T.Array aty -> "[" ^ ty_to_string fmt aty ^ "; ?]" - | T.Slice sty -> "[" ^ ty_to_string fmt sty ^ "]" - | T.Ref (r, rty, ref_kind) -> ( - match ref_kind with - | T.Mut -> - "&" ^ fmt.r_to_string r ^ " mut (" ^ ty_to_string fmt rty ^ ")" - | T.Shared -> - "&" ^ fmt.r_to_string r ^ " (" ^ ty_to_string fmt rty ^ ")") - - and params_to_string (fmt : 'r type_formatter) (is_tuple : bool) - (regions : 'r list) (types : 'r T.ty list) : string = - let regions = List.map fmt.r_to_string regions in - let types = List.map (ty_to_string fmt) types in - let params = String.concat ", " (List.append regions types) in - if is_tuple then "(" ^ params ^ ")" - else if List.length regions + List.length types > 0 then "<" ^ params ^ ">" - else "" - - let sty_to_string (fmt : stype_formatter) (ty : T.sty) : string = - ty_to_string fmt ty - - let rty_to_string (fmt : rtype_formatter) (ty : T.rty) : string = - ty_to_string fmt ty - - let ety_to_string (fmt : etype_formatter) (ty : T.ety) : string = - ty_to_string fmt ty - - let field_to_string fmt (f : T.field) : string = - match f.field_name with - | Some field_name -> field_name ^ " : " ^ ty_to_string fmt f.field_ty - | None -> ty_to_string fmt f.field_ty - - let variant_to_string fmt (v : T.variant) : string = - v.variant_name ^ "(" - ^ String.concat ", " (List.map (field_to_string fmt) v.fields) - ^ ")" - - let type_decl_to_string (type_decl_id_to_string : T.TypeDeclId.id -> string) - (def : T.type_decl) : string = - let regions = def.region_params in - let types = def.type_params in - let rid_to_string rid = - match List.find_opt (fun rv -> rv.T.index = rid) regions with - | Some rv -> region_var_to_string rv - | None -> failwith "Unreachable" - in - let r_to_string = region_to_string rid_to_string in - let type_var_id_to_string id = - match List.find_opt (fun tv -> tv.T.index = id) types with - | Some tv -> type_var_to_string tv - | None -> failwith "Unreachable" - in - let fmt = { r_to_string; type_var_id_to_string; type_decl_id_to_string } in - let name = name_to_string def.name in - let params = - if List.length regions + List.length types > 0 then - let regions = List.map region_var_to_string regions in - let types = List.map type_var_to_string types in - let params = String.concat ", " (List.append regions types) in - "<" ^ params ^ ">" - else "" - in - match def.kind with - | T.Struct fields -> - if List.length fields > 0 then - let fields = - String.concat "," - (List.map (fun f -> "\n " ^ field_to_string fmt f) fields) - in - "struct " ^ name ^ params ^ "{" ^ fields ^ "}" - else "struct " ^ name ^ params ^ "{}" - | T.Enum variants -> - let variants = - List.map (fun v -> "| " ^ variant_to_string fmt v) variants - in - let variants = String.concat "\n" variants in - "enum " ^ name ^ params ^ " =\n" ^ variants - | T.Opaque -> "opaque type " ^ name ^ params -end - -module PT = Types (* local module *) - -(** Pretty-printing for values *) -module Values = struct - type value_formatter = { - rvar_to_string : T.RegionVarId.id -> string; - r_to_string : T.RegionId.id -> string; - type_var_id_to_string : T.TypeVarId.id -> string; - type_decl_id_to_string : T.TypeDeclId.id -> string; - adt_variant_to_string : T.TypeDeclId.id -> T.VariantId.id -> string; - var_id_to_string : V.VarId.id -> string; - adt_field_names : - T.TypeDeclId.id -> T.VariantId.id option -> string list option; - } - - let value_to_etype_formatter (fmt : value_formatter) : PT.etype_formatter = - { - PT.r_to_string = PT.erased_region_to_string; - PT.type_var_id_to_string = fmt.type_var_id_to_string; - PT.type_decl_id_to_string = fmt.type_decl_id_to_string; - } - - let value_to_rtype_formatter (fmt : value_formatter) : PT.rtype_formatter = - { - PT.r_to_string = PT.region_to_string fmt.r_to_string; - PT.type_var_id_to_string = fmt.type_var_id_to_string; - PT.type_decl_id_to_string = fmt.type_decl_id_to_string; - } - - let value_to_stype_formatter (fmt : value_formatter) : PT.stype_formatter = - { - PT.r_to_string = PT.region_to_string fmt.rvar_to_string; - PT.type_var_id_to_string = fmt.type_var_id_to_string; - PT.type_decl_id_to_string = fmt.type_decl_id_to_string; - } - - let var_id_to_string (id : V.VarId.id) : string = - "var@" ^ V.VarId.to_string id - - let big_int_to_string (bi : V.big_int) : string = Z.to_string bi - - let scalar_value_to_string (sv : V.scalar_value) : string = - big_int_to_string sv.value ^ ": " ^ PT.integer_type_to_string sv.int_ty - - let constant_value_to_string (cv : V.constant_value) : string = - match cv with - | Scalar sv -> scalar_value_to_string sv - | Bool b -> Bool.to_string b - | Char c -> String.make 1 c - | String s -> s - - let symbolic_value_id_to_string (id : V.SymbolicValueId.id) : string = - "s@" ^ V.SymbolicValueId.to_string id - - let symbolic_value_to_string (fmt : PT.rtype_formatter) - (sv : V.symbolic_value) : string = - symbolic_value_id_to_string sv.sv_id ^ " : " ^ PT.rty_to_string fmt sv.sv_ty - - let symbolic_value_proj_to_string (fmt : value_formatter) - (sv : V.symbolic_value) (rty : T.rty) : string = - symbolic_value_id_to_string sv.sv_id - ^ " : " - ^ PT.ty_to_string (value_to_rtype_formatter fmt) sv.sv_ty - ^ " <: " - ^ PT.ty_to_string (value_to_rtype_formatter fmt) rty - - (* TODO: it may be a good idea to try to factorize this function with - * typed_avalue_to_string. At some point we had done it, because [typed_value] - * and [typed_avalue] were instances of the same general type [g_typed_value], - * but then we removed this general type because it proved to be a bad idea. *) - let rec typed_value_to_string (fmt : value_formatter) (v : V.typed_value) : - string = - let ty_fmt : PT.etype_formatter = value_to_etype_formatter fmt in - match v.value with - | Concrete cv -> constant_value_to_string cv - | Adt av -> ( - let field_values = - List.map (typed_value_to_string fmt) av.field_values - in - match v.ty with - | T.Adt (T.Tuple, _, _) -> - (* Tuple *) - "(" ^ String.concat ", " field_values ^ ")" - | T.Adt (T.AdtId def_id, _, _) -> - (* "Regular" ADT *) - let adt_ident = - match av.variant_id with - | Some vid -> fmt.adt_variant_to_string def_id vid - | None -> fmt.type_decl_id_to_string def_id - in - if List.length field_values > 0 then - match fmt.adt_field_names def_id av.V.variant_id with - | None -> - let field_values = String.concat ", " field_values in - adt_ident ^ " (" ^ field_values ^ ")" - | Some field_names -> - let field_values = List.combine field_names field_values in - let field_values = - List.map - (fun (field, value) -> field ^ " = " ^ value ^ ";") - field_values - in - let field_values = String.concat " " field_values in - adt_ident ^ " { " ^ field_values ^ " }" - else adt_ident - | T.Adt (T.Assumed aty, _, _) -> ( - (* Assumed type *) - match (aty, field_values) with - | Box, [ bv ] -> "@Box(" ^ bv ^ ")" - | Option, _ -> - if av.variant_id = Some T.option_some_id then - "@Option::Some(" - ^ Collections.List.to_cons_nil field_values - ^ ")" - else if av.variant_id = Some T.option_none_id then ( - assert (field_values = []); - "@Option::None") - else failwith "Unreachable" - | Vec, _ -> "@Vec[" ^ String.concat ", " field_values ^ "]" - | _ -> failwith "Inconsistent value") - | _ -> failwith "Inconsistent typed value") - | Bottom -> "⊥ : " ^ PT.ty_to_string ty_fmt v.ty - | Borrow bc -> borrow_content_to_string fmt bc - | Loan lc -> loan_content_to_string fmt lc - | Symbolic s -> symbolic_value_to_string (value_to_rtype_formatter fmt) s - - and borrow_content_to_string (fmt : value_formatter) (bc : V.borrow_content) : - string = - match bc with - | SharedBorrow (_, bid) -> "⌊shared@" ^ V.BorrowId.to_string bid ^ "⌋" - | MutBorrow (bid, tv) -> - "&mut@" ^ V.BorrowId.to_string bid ^ " (" - ^ typed_value_to_string fmt tv - ^ ")" - | InactivatedMutBorrow (_, bid) -> - "⌊inactivated_mut@" ^ V.BorrowId.to_string bid ^ "⌋" - - and loan_content_to_string (fmt : value_formatter) (lc : V.loan_content) : - string = - match lc with - | SharedLoan (loans, v) -> - let loans = V.BorrowId.Set.to_string None loans in - "@shared_loan(" ^ loans ^ ", " ^ typed_value_to_string fmt v ^ ")" - | MutLoan bid -> "⌊mut@" ^ V.BorrowId.to_string bid ^ "⌋" - - let abstract_shared_borrow_to_string (fmt : value_formatter) - (abs : V.abstract_shared_borrow) : string = - match abs with - | AsbBorrow bid -> V.BorrowId.to_string bid - | AsbProjReborrows (sv, rty) -> - "{" ^ symbolic_value_proj_to_string fmt sv rty ^ "}" - - let abstract_shared_borrows_to_string (fmt : value_formatter) - (abs : V.abstract_shared_borrows) : string = - "{" - ^ String.concat "," (List.map (abstract_shared_borrow_to_string fmt) abs) - ^ "}" - - let rec aproj_to_string (fmt : value_formatter) (pv : V.aproj) : string = - match pv with - | AProjLoans (sv, given_back) -> - let given_back = - if given_back = [] then "" - else - let given_back = List.map snd given_back in - let given_back = List.map (aproj_to_string fmt) given_back in - " (" ^ String.concat "," given_back ^ ") " - in - "⌊" - ^ symbolic_value_to_string (value_to_rtype_formatter fmt) sv - ^ given_back ^ "⌋" - | AProjBorrows (sv, rty) -> - "(" ^ symbolic_value_proj_to_string fmt sv rty ^ ")" - | AEndedProjLoans (_, given_back) -> - if given_back = [] then "_" - else - let given_back = List.map snd given_back in - let given_back = List.map (aproj_to_string fmt) given_back in - "ended_aproj_loans (" ^ String.concat "," given_back ^ ")" - | AEndedProjBorrows _mv -> "_" - | AIgnoredProjBorrows -> "_" - - let rec typed_avalue_to_string (fmt : value_formatter) (v : V.typed_avalue) : - string = - let ty_fmt : PT.rtype_formatter = value_to_rtype_formatter fmt in - match v.value with - | AConcrete cv -> constant_value_to_string cv - | AAdt av -> ( - let field_values = - List.map (typed_avalue_to_string fmt) av.field_values - in - match v.ty with - | T.Adt (T.Tuple, _, _) -> - (* Tuple *) - "(" ^ String.concat ", " field_values ^ ")" - | T.Adt (T.AdtId def_id, _, _) -> - (* "Regular" ADT *) - let adt_ident = - match av.variant_id with - | Some vid -> fmt.adt_variant_to_string def_id vid - | None -> fmt.type_decl_id_to_string def_id - in - if List.length field_values > 0 then - match fmt.adt_field_names def_id av.V.variant_id with - | None -> - let field_values = String.concat ", " field_values in - adt_ident ^ " (" ^ field_values ^ ")" - | Some field_names -> - let field_values = List.combine field_names field_values in - let field_values = - List.map - (fun (field, value) -> field ^ " = " ^ value ^ ";") - field_values - in - let field_values = String.concat " " field_values in - adt_ident ^ " { " ^ field_values ^ " }" - else adt_ident - | T.Adt (T.Assumed aty, _, _) -> ( - (* Assumed type *) - match (aty, field_values) with - | Box, [ bv ] -> "@Box(" ^ bv ^ ")" - | _ -> failwith "Inconsistent value") - | _ -> failwith "Inconsistent typed value") - | ABottom -> "⊥ : " ^ PT.ty_to_string ty_fmt v.ty - | ABorrow bc -> aborrow_content_to_string fmt bc - | ALoan lc -> aloan_content_to_string fmt lc - | ASymbolic s -> aproj_to_string fmt s - | AIgnored -> "_" - - and aloan_content_to_string (fmt : value_formatter) (lc : V.aloan_content) : - string = - match lc with - | AMutLoan (bid, av) -> - "⌊mut@" ^ V.BorrowId.to_string bid ^ ", " - ^ typed_avalue_to_string fmt av - ^ "⌋" - | ASharedLoan (loans, v, av) -> - let loans = V.BorrowId.Set.to_string None loans in - "@shared_loan(" ^ loans ^ ", " - ^ typed_value_to_string fmt v - ^ ", " - ^ typed_avalue_to_string fmt av - ^ ")" - | AEndedMutLoan ml -> - "@ended_mut_loan{" - ^ typed_avalue_to_string fmt ml.child - ^ "; " - ^ typed_avalue_to_string fmt ml.given_back - ^ " }" - | AEndedSharedLoan (v, av) -> - "@ended_shared_loan(" - ^ typed_value_to_string fmt v - ^ ", " - ^ typed_avalue_to_string fmt av - ^ ")" - | AIgnoredMutLoan (bid, av) -> - "@ignored_mut_loan(" ^ V.BorrowId.to_string bid ^ ", " - ^ typed_avalue_to_string fmt av - ^ ")" - | AEndedIgnoredMutLoan ml -> - "@ended_ignored_mut_loan{ " - ^ typed_avalue_to_string fmt ml.child - ^ "; " - ^ typed_avalue_to_string fmt ml.given_back - ^ "}" - | AIgnoredSharedLoan sl -> - "@ignored_shared_loan(" ^ typed_avalue_to_string fmt sl ^ ")" - - and aborrow_content_to_string (fmt : value_formatter) (bc : V.aborrow_content) - : string = - match bc with - | AMutBorrow (_, bid, av) -> - "&mut@" ^ V.BorrowId.to_string bid ^ " (" - ^ typed_avalue_to_string fmt av - ^ ")" - | ASharedBorrow bid -> "⌊shared@" ^ V.BorrowId.to_string bid ^ "⌋" - | AIgnoredMutBorrow (opt_bid, av) -> - "@ignored_mut_borrow(" - ^ option_to_string V.BorrowId.to_string opt_bid - ^ ", " - ^ typed_avalue_to_string fmt av - ^ ")" - | AEndedMutBorrow (_mv, child) -> - "@ended_mut_borrow(" ^ typed_avalue_to_string fmt child ^ ")" - | AEndedIgnoredMutBorrow - { child; given_back_loans_proj; given_back_meta = _ } -> - "@ended_ignored_mut_borrow{ " - ^ typed_avalue_to_string fmt child - ^ "; " - ^ typed_avalue_to_string fmt given_back_loans_proj - ^ ")" - | AEndedSharedBorrow -> "@ended_shared_borrow" - | AProjSharedBorrow sb -> - "@ignored_shared_borrow(" - ^ abstract_shared_borrows_to_string fmt sb - ^ ")" - - let abs_to_string (fmt : value_formatter) (indent : string) - (indent_incr : string) (abs : V.abs) : string = - let indent2 = indent ^ indent_incr in - let avs = - List.map (fun av -> indent2 ^ typed_avalue_to_string fmt av) abs.avalues - in - let avs = String.concat ",\n" avs in - indent ^ "abs@" - ^ V.AbstractionId.to_string abs.abs_id - ^ "{parents=" - ^ V.AbstractionId.Set.to_string None abs.parents - ^ "}" ^ "{regions=" - ^ T.RegionId.Set.to_string None abs.regions - ^ "}" ^ " {\n" ^ avs ^ "\n" ^ indent ^ "}" -end - -module PV = Values (* local module *) - -(** Pretty-printing for contexts *) -module Contexts = struct - let binder_to_string (bv : C.binder) : string = - match bv.name with - | None -> PV.var_id_to_string bv.index - | Some name -> name - - let env_elem_to_string (fmt : PV.value_formatter) (indent : string) - (indent_incr : string) (ev : C.env_elem) : string = - match ev with - | Var (var, tv) -> - let bv = - match var with Some var -> binder_to_string var | None -> "_" - in - indent ^ bv ^ " -> " ^ PV.typed_value_to_string fmt tv ^ " ;" - | Abs abs -> PV.abs_to_string fmt indent indent_incr abs - | Frame -> failwith "Can't print a Frame element" - - let opt_env_elem_to_string (fmt : PV.value_formatter) (indent : string) - (indent_incr : string) (ev : C.env_elem option) : string = - match ev with - | None -> indent ^ "..." - | Some ev -> env_elem_to_string fmt indent indent_incr ev - - (** Filters "dummy" bindings from an environment, to gain space and clarity/ - See [env_to_string]. *) - let filter_env (env : C.env) : C.env_elem option list = - (* We filter: - * - non-dummy bindings which point to ⊥ - * - dummy bindings which don't contain loans nor borrows - * Note that the first case can sometimes be confusing: we may try to improve - * it... - *) - let filter_elem (ev : C.env_elem) : C.env_elem option = - match ev with - | Var (Some _, tv) -> - (* Not a dummy binding: check if the value is ⊥ *) - if VU.is_bottom tv.value then None else Some ev - | Var (None, tv) -> - (* Dummy binding: check if the value contains borrows or loans *) - if VU.borrows_in_value tv || VU.loans_in_value tv then Some ev - else None - | _ -> Some ev - in - let env = List.map filter_elem env in - (* We collapse groups of filtered values - so that we can print one - * single "..." for a whole group of filtered values *) - let rec group_filtered (env : C.env_elem option list) : - C.env_elem option list = - match env with - | [] -> [] - | None :: None :: env -> group_filtered (None :: env) - | x :: env -> x :: group_filtered env - in - group_filtered env - - (** Environments can have a lot of dummy or uninitialized values: [filter] - allows to filter them when printing, replacing groups of such bindings with - "..." to gain space and clarity. - *) - let env_to_string (filter : bool) (fmt : PV.value_formatter) (env : C.env) : - string = - let env = - if filter then filter_env env else List.map (fun ev -> Some ev) env - in - "{\n" - ^ String.concat "\n" - (List.map (fun ev -> opt_env_elem_to_string fmt " " " " ev) env) - ^ "\n}" - - type ctx_formatter = PV.value_formatter - - let ctx_to_etype_formatter (fmt : ctx_formatter) : PT.etype_formatter = - PV.value_to_etype_formatter fmt - - let ctx_to_rtype_formatter (fmt : ctx_formatter) : PT.rtype_formatter = - PV.value_to_rtype_formatter fmt - - let type_ctx_to_adt_variant_to_string_fun - (ctx : T.type_decl T.TypeDeclId.Map.t) : - T.TypeDeclId.id -> T.VariantId.id -> string = - fun def_id variant_id -> - let def = T.TypeDeclId.Map.find def_id ctx in - match def.kind with - | Struct _ | Opaque -> failwith "Unreachable" - | Enum variants -> - let variant = T.VariantId.nth variants variant_id in - name_to_string def.name ^ "::" ^ variant.variant_name - - let type_ctx_to_adt_field_names_fun (ctx : T.type_decl T.TypeDeclId.Map.t) : - T.TypeDeclId.id -> T.VariantId.id option -> string list option = - fun def_id opt_variant_id -> - let def = T.TypeDeclId.Map.find def_id ctx in - let fields = TU.type_decl_get_fields def opt_variant_id in - (* There are two cases: either all the fields have names, or none of them - * has names *) - let has_names = - List.exists (fun f -> Option.is_some f.T.field_name) fields - in - if has_names then - let fields = List.map (fun f -> Option.get f.T.field_name) fields in - Some fields - else None - - let eval_ctx_to_ctx_formatter (ctx : C.eval_ctx) : ctx_formatter = - (* We shouldn't use rvar_to_string *) - let rvar_to_string _r = failwith "Unexpected use of rvar_to_string" in - let r_to_string r = PT.region_id_to_string r in - - let type_var_id_to_string vid = - let v = C.lookup_type_var ctx vid in - v.name - in - let type_decl_id_to_string def_id = - let def = C.ctx_lookup_type_decl ctx def_id in - name_to_string def.name - in - let adt_variant_to_string = - type_ctx_to_adt_variant_to_string_fun ctx.type_context.type_decls - in - let var_id_to_string vid = - let bv = C.ctx_lookup_binder ctx vid in - binder_to_string bv - in - let adt_field_names = - type_ctx_to_adt_field_names_fun ctx.type_context.type_decls - in - { - rvar_to_string; - r_to_string; - type_var_id_to_string; - type_decl_id_to_string; - adt_variant_to_string; - var_id_to_string; - adt_field_names; - } - - (** Split an [env] at every occurrence of [Frame], eliminating those elements. - Also reorders the frames and the values in the frames according to the - following order: - * frames: from the current frame to the first pushed (oldest frame) - * values: from the first pushed (oldest) to the last pushed - *) - let split_env_according_to_frames (env : C.env) : C.env list = - let rec split_aux (frames : C.env list) (curr_frame : C.env) (env : C.env) = - match env with - | [] -> - if List.length curr_frame > 0 then curr_frame :: frames else frames - | Frame :: env' -> split_aux (curr_frame :: frames) [] env' - | ev :: env' -> split_aux frames (ev :: curr_frame) env' - in - let frames = split_aux [] [] env in - frames - - let eval_ctx_to_string (ctx : C.eval_ctx) : string = - let fmt = eval_ctx_to_ctx_formatter ctx in - let ended_regions = T.RegionId.Set.to_string None ctx.ended_regions in - let frames = split_env_according_to_frames ctx.env in - let num_frames = List.length frames in - let frames = - List.mapi - (fun i f -> - let num_bindings = ref 0 in - let num_dummies = ref 0 in - let num_abs = ref 0 in - List.iter - (fun ev -> - match ev with - | C.Var (None, _) -> num_dummies := !num_abs + 1 - | C.Var (Some _, _) -> num_bindings := !num_bindings + 1 - | C.Abs _ -> num_abs := !num_abs + 1 - | _ -> raise (Failure "Unreachable")) - f; - "\n# Frame " ^ string_of_int i ^ ":" ^ "\n- locals: " - ^ string_of_int !num_bindings - ^ "\n- dummy bindings: " ^ string_of_int !num_dummies - ^ "\n- abstractions: " ^ string_of_int !num_abs ^ "\n" - ^ env_to_string true fmt f ^ "\n") - frames - in - "# Ended regions: " ^ ended_regions ^ "\n" ^ "# " ^ string_of_int num_frames - ^ " frame(s)\n" ^ String.concat "" frames -end - -module PC = Contexts (* local module *) - -(** Pretty-printing for contexts (generic functions) *) -module LlbcAst = struct - let var_to_string (var : A.var) : string = - match var.name with - | None -> V.VarId.to_string var.index - | Some name -> name - - type ast_formatter = { - rvar_to_string : T.RegionVarId.id -> string; - r_to_string : T.RegionId.id -> string; - type_var_id_to_string : T.TypeVarId.id -> string; - type_decl_id_to_string : T.TypeDeclId.id -> string; - adt_variant_to_string : T.TypeDeclId.id -> T.VariantId.id -> string; - adt_field_to_string : - T.TypeDeclId.id -> T.VariantId.id option -> T.FieldId.id -> string option; - var_id_to_string : V.VarId.id -> string; - adt_field_names : - T.TypeDeclId.id -> T.VariantId.id option -> string list option; - fun_decl_id_to_string : A.FunDeclId.id -> string; - global_decl_id_to_string : A.GlobalDeclId.id -> string; - } - - let ast_to_ctx_formatter (fmt : ast_formatter) : PC.ctx_formatter = - { - PV.rvar_to_string = fmt.rvar_to_string; - PV.r_to_string = fmt.r_to_string; - PV.type_var_id_to_string = fmt.type_var_id_to_string; - PV.type_decl_id_to_string = fmt.type_decl_id_to_string; - PV.adt_variant_to_string = fmt.adt_variant_to_string; - PV.var_id_to_string = fmt.var_id_to_string; - PV.adt_field_names = fmt.adt_field_names; - } - - let ast_to_value_formatter (fmt : ast_formatter) : PV.value_formatter = - ast_to_ctx_formatter fmt - - let ast_to_etype_formatter (fmt : ast_formatter) : PT.etype_formatter = - { - PT.r_to_string = PT.erased_region_to_string; - PT.type_var_id_to_string = fmt.type_var_id_to_string; - PT.type_decl_id_to_string = fmt.type_decl_id_to_string; - } - - let ast_to_rtype_formatter (fmt : ast_formatter) : PT.rtype_formatter = - { - PT.r_to_string = PT.region_to_string fmt.r_to_string; - PT.type_var_id_to_string = fmt.type_var_id_to_string; - PT.type_decl_id_to_string = fmt.type_decl_id_to_string; - } - - let ast_to_stype_formatter (fmt : ast_formatter) : PT.stype_formatter = - { - PT.r_to_string = PT.region_to_string fmt.rvar_to_string; - PT.type_var_id_to_string = fmt.type_var_id_to_string; - PT.type_decl_id_to_string = fmt.type_decl_id_to_string; - } - - let type_ctx_to_adt_field_to_string_fun (ctx : T.type_decl T.TypeDeclId.Map.t) - : - T.TypeDeclId.id -> T.VariantId.id option -> T.FieldId.id -> string option - = - fun def_id opt_variant_id field_id -> - let def = T.TypeDeclId.Map.find def_id ctx in - let fields = TU.type_decl_get_fields def opt_variant_id in - let field = T.FieldId.nth fields field_id in - field.T.field_name - - let eval_ctx_to_ast_formatter (ctx : C.eval_ctx) : ast_formatter = - let ctx_fmt = PC.eval_ctx_to_ctx_formatter ctx in - let adt_field_to_string = - type_ctx_to_adt_field_to_string_fun ctx.type_context.type_decls - in - let fun_decl_id_to_string def_id = - let def = C.ctx_lookup_fun_decl ctx def_id in - fun_name_to_string def.name - in - let global_decl_id_to_string def_id = - let def = C.ctx_lookup_global_decl ctx def_id in - global_name_to_string def.name - in - { - rvar_to_string = ctx_fmt.PV.rvar_to_string; - r_to_string = ctx_fmt.PV.r_to_string; - type_var_id_to_string = ctx_fmt.PV.type_var_id_to_string; - type_decl_id_to_string = ctx_fmt.PV.type_decl_id_to_string; - adt_variant_to_string = ctx_fmt.PV.adt_variant_to_string; - var_id_to_string = ctx_fmt.PV.var_id_to_string; - adt_field_names = ctx_fmt.PV.adt_field_names; - adt_field_to_string; - fun_decl_id_to_string; - global_decl_id_to_string; - } - - let fun_decl_to_ast_formatter (type_decls : T.type_decl T.TypeDeclId.Map.t) - (fun_decls : A.fun_decl A.FunDeclId.Map.t) - (global_decls : A.global_decl A.GlobalDeclId.Map.t) (fdef : A.fun_decl) : - ast_formatter = - let rvar_to_string r = - let rvar = T.RegionVarId.nth fdef.signature.region_params r in - PT.region_var_to_string rvar - in - let r_to_string r = PT.region_id_to_string r in - - let type_var_id_to_string vid = - let var = T.TypeVarId.nth fdef.signature.type_params vid in - PT.type_var_to_string var - in - let type_decl_id_to_string def_id = - let def = T.TypeDeclId.Map.find def_id type_decls in - name_to_string def.name - in - let adt_variant_to_string = - PC.type_ctx_to_adt_variant_to_string_fun type_decls - in - let var_id_to_string vid = - let var = V.VarId.nth (Option.get fdef.body).locals vid in - var_to_string var - in - let adt_field_names = PC.type_ctx_to_adt_field_names_fun type_decls in - let adt_field_to_string = type_ctx_to_adt_field_to_string_fun type_decls in - let fun_decl_id_to_string def_id = - let def = A.FunDeclId.Map.find def_id fun_decls in - fun_name_to_string def.name - in - let global_decl_id_to_string def_id = - let def = A.GlobalDeclId.Map.find def_id global_decls in - global_name_to_string def.name - in - { - rvar_to_string; - r_to_string; - type_var_id_to_string; - type_decl_id_to_string; - adt_variant_to_string; - var_id_to_string; - adt_field_names; - adt_field_to_string; - fun_decl_id_to_string; - global_decl_id_to_string; - } - - let rec projection_to_string (fmt : ast_formatter) (inside : string) - (p : E.projection) : string = - match p with - | [] -> inside - | pe :: p' -> ( - let s = projection_to_string fmt inside p' in - match pe with - | E.Deref -> "*(" ^ s ^ ")" - | E.DerefBox -> "deref_box(" ^ s ^ ")" - | E.Field (E.ProjOption variant_id, fid) -> - assert (variant_id = T.option_some_id); - assert (fid = T.FieldId.zero); - "(" ^ s ^ " as Option::Some)." ^ T.FieldId.to_string fid - | E.Field (E.ProjTuple _, fid) -> - "(" ^ s ^ ")." ^ T.FieldId.to_string fid - | E.Field (E.ProjAdt (adt_id, opt_variant_id), fid) -> ( - let field_name = - match fmt.adt_field_to_string adt_id opt_variant_id fid with - | Some field_name -> field_name - | None -> T.FieldId.to_string fid - in - match opt_variant_id with - | None -> "(" ^ s ^ ")." ^ field_name - | Some variant_id -> - let variant_name = - fmt.adt_variant_to_string adt_id variant_id - in - "(" ^ s ^ " as " ^ variant_name ^ ")." ^ field_name)) - - let place_to_string (fmt : ast_formatter) (p : E.place) : string = - let var = fmt.var_id_to_string p.E.var_id in - projection_to_string fmt var p.E.projection - - let unop_to_string (unop : E.unop) : string = - match unop with - | E.Not -> "¬" - | E.Neg -> "-" - | E.Cast (src, tgt) -> - "cast<" - ^ PT.integer_type_to_string src - ^ "," - ^ PT.integer_type_to_string tgt - ^ ">" - - let binop_to_string (binop : E.binop) : string = - match binop with - | E.BitXor -> "^" - | E.BitAnd -> "&" - | E.BitOr -> "|" - | E.Eq -> "==" - | E.Lt -> "<" - | E.Le -> "<=" - | E.Ne -> "!=" - | E.Ge -> ">=" - | E.Gt -> ">" - | E.Div -> "/" - | E.Rem -> "%" - | E.Add -> "+" - | E.Sub -> "-" - | E.Mul -> "*" - | E.Shl -> "<<" - | E.Shr -> ">>" - - let operand_to_string (fmt : ast_formatter) (op : E.operand) : string = - match op with - | E.Copy p -> "copy " ^ place_to_string fmt p - | E.Move p -> "move " ^ place_to_string fmt p - | E.Constant (ty, cv) -> - "(" - ^ PV.constant_value_to_string cv - ^ " : " - ^ PT.ety_to_string (ast_to_etype_formatter fmt) ty - ^ ")" - - let rvalue_to_string (fmt : ast_formatter) (rv : E.rvalue) : string = - match rv with - | E.Use op -> operand_to_string fmt op - | E.Ref (p, bk) -> ( - let p = place_to_string fmt p in - match bk with - | E.Shared -> "&" ^ p - | E.Mut -> "&mut " ^ p - | E.TwoPhaseMut -> "&two-phase " ^ p) - | E.UnaryOp (unop, op) -> - unop_to_string unop ^ " " ^ operand_to_string fmt op - | E.BinaryOp (binop, op1, op2) -> - operand_to_string fmt op1 ^ " " ^ binop_to_string binop ^ " " - ^ operand_to_string fmt op2 - | E.Discriminant p -> "discriminant(" ^ place_to_string fmt p ^ ")" - | E.Aggregate (akind, ops) -> ( - let ops = List.map (operand_to_string fmt) ops in - match akind with - | E.AggregatedTuple -> "(" ^ String.concat ", " ops ^ ")" - | E.AggregatedOption (variant_id, _ty) -> - if variant_id == T.option_none_id then ( - assert (ops == []); - "@Option::None") - else if variant_id == T.option_some_id then ( - assert (List.length ops == 1); - let op = List.hd ops in - "@Option::Some(" ^ op ^ ")") - else raise (Failure "Unreachable") - | E.AggregatedAdt (def_id, opt_variant_id, _regions, _types) -> - let adt_name = fmt.type_decl_id_to_string def_id in - let variant_name = - match opt_variant_id with - | None -> adt_name - | Some variant_id -> - adt_name ^ "::" ^ fmt.adt_variant_to_string def_id variant_id - in - let fields = - match fmt.adt_field_names def_id opt_variant_id with - | None -> "(" ^ String.concat ", " ops ^ ")" - | Some field_names -> - let fields = List.combine field_names ops in - let fields = - List.map - (fun (field, value) -> field ^ " = " ^ value ^ ";") - fields - in - let fields = String.concat " " fields in - "{ " ^ fields ^ " }" - in - variant_name ^ " " ^ fields) - - let rec statement_to_string (fmt : ast_formatter) (indent : string) - (indent_incr : string) (st : A.statement) : string = - raw_statement_to_string fmt indent indent_incr st.content - - and raw_statement_to_string (fmt : ast_formatter) (indent : string) - (indent_incr : string) (st : A.raw_statement) : string = - match st with - | A.Assign (p, rv) -> - indent ^ place_to_string fmt p ^ " := " ^ rvalue_to_string fmt rv - | A.AssignGlobal { dst; global } -> - indent ^ fmt.var_id_to_string dst ^ " := global " - ^ fmt.global_decl_id_to_string global - | A.FakeRead p -> indent ^ "fake_read " ^ place_to_string fmt p - | A.SetDiscriminant (p, variant_id) -> - (* TODO: improve this to lookup the variant name by using the def id *) - indent ^ "set_discriminant(" ^ place_to_string fmt p ^ ", " - ^ T.VariantId.to_string variant_id - ^ ")" - | A.Drop p -> indent ^ "drop(" ^ place_to_string fmt p ^ ")" - | A.Assert a -> - let cond = operand_to_string fmt a.A.cond in - if a.A.expected then indent ^ "assert(" ^ cond ^ ")" - else indent ^ "assert(¬" ^ cond ^ ")" - | A.Call call -> - let ty_fmt = ast_to_etype_formatter fmt in - let t_params = - if List.length call.A.type_args > 0 then - "<" - ^ String.concat "," - (List.map (PT.ty_to_string ty_fmt) call.A.type_args) - ^ ">" - else "" - in - let args = List.map (operand_to_string fmt) call.A.args in - let args = "(" ^ String.concat ", " args ^ ")" in - let name_args = - match call.A.func with - | A.Regular fid -> fmt.fun_decl_id_to_string fid ^ t_params - | A.Assumed fid -> ( - match fid with - | A.Replace -> "core::mem::replace" ^ t_params - | A.BoxNew -> "alloc::boxed::Box" ^ t_params ^ "::new" - | A.BoxDeref -> - "core::ops::deref::Deref::deref" - | A.BoxDerefMut -> - "core::ops::deref::DerefMut" ^ t_params ^ "::deref_mut" - | A.BoxFree -> "alloc::alloc::box_free" ^ t_params - | A.VecNew -> "alloc::vec::Vec" ^ t_params ^ "::new" - | A.VecPush -> "alloc::vec::Vec" ^ t_params ^ "::push" - | A.VecInsert -> "alloc::vec::Vec" ^ t_params ^ "::insert" - | A.VecLen -> "alloc::vec::Vec" ^ t_params ^ "::len" - | A.VecIndex -> - "core::ops::index::Index::index" - | A.VecIndexMut -> - "core::ops::index::IndexMut::index_mut") - in - let dest = place_to_string fmt call.A.dest in - indent ^ dest ^ " := move " ^ name_args ^ args - | A.Panic -> indent ^ "panic" - | A.Return -> indent ^ "return" - | A.Break i -> indent ^ "break " ^ string_of_int i - | A.Continue i -> indent ^ "continue " ^ string_of_int i - | A.Nop -> indent ^ "nop" - | A.Sequence (st1, st2) -> - statement_to_string fmt indent indent_incr st1 - ^ ";\n" - ^ statement_to_string fmt indent indent_incr st2 - | A.Switch (op, tgts) -> ( - let op = operand_to_string fmt op in - match tgts with - | A.If (true_st, false_st) -> - let inner_indent = indent ^ indent_incr in - let inner_to_string = - statement_to_string fmt inner_indent indent_incr - in - let true_st = inner_to_string true_st in - let false_st = inner_to_string false_st in - indent ^ "if (" ^ op ^ ") {\n" ^ true_st ^ "\n" ^ indent ^ "}\n" - ^ indent ^ "else {\n" ^ false_st ^ "\n" ^ indent ^ "}" - | A.SwitchInt (_ty, branches, otherwise) -> - let indent1 = indent ^ indent_incr in - let indent2 = indent1 ^ indent_incr in - let inner_to_string2 = - statement_to_string fmt indent2 indent_incr - in - let branches = - List.map - (fun (svl, be) -> - let svl = - List.map (fun sv -> "| " ^ PV.scalar_value_to_string sv) svl - in - let svl = String.concat " " svl in - indent1 ^ svl ^ " => {\n" ^ inner_to_string2 be ^ "\n" - ^ indent1 ^ "}") - branches - in - let branches = String.concat "\n" branches in - let branches = - branches ^ "\n" ^ indent1 ^ "_ => {\n" - ^ inner_to_string2 otherwise ^ "\n" ^ indent1 ^ "}" - in - indent ^ "switch (" ^ op ^ ") {\n" ^ branches ^ "\n" ^ indent ^ "}") - | A.Loop loop_st -> - indent ^ "loop {\n" - ^ statement_to_string fmt (indent ^ indent_incr) indent_incr loop_st - ^ "\n" ^ indent ^ "}" - - let var_to_string (v : A.var) : string = - match v.name with None -> PV.var_id_to_string v.index | Some name -> name - - let fun_decl_to_string (fmt : ast_formatter) (indent : string) - (indent_incr : string) (def : A.fun_decl) : string = - let sty_fmt = ast_to_stype_formatter fmt in - let sty_to_string = PT.sty_to_string sty_fmt in - let ety_fmt = ast_to_etype_formatter fmt in - let ety_to_string = PT.ety_to_string ety_fmt in - let sg = def.signature in - - (* Function name *) - let name = fun_name_to_string def.A.name in - - (* Region/type parameters *) - let regions = sg.region_params in - let types = sg.type_params in - let params = - if List.length regions + List.length types = 0 then "" - else - let regions = List.map PT.region_var_to_string regions in - let types = List.map PT.type_var_to_string types in - "<" ^ String.concat "," (List.append regions types) ^ ">" - in - - (* Return type *) - let ret_ty = sg.output in - let ret_ty = - if TU.ty_is_unit ret_ty then "" else " -> " ^ sty_to_string ret_ty - in - - (* We print the declaration differently if it is opaque (no body) or transparent - * (we have access to a body) *) - match def.body with - | None -> - (* Arguments *) - let input_tys = sg.inputs in - let args = List.map sty_to_string input_tys in - let args = String.concat ", " args in - - (* Put everything together *) - indent ^ "opaque fn " ^ name ^ params ^ "(" ^ args ^ ")" ^ ret_ty - | Some body -> - (* Arguments *) - let inputs = List.tl body.locals in - let inputs, _aux_locals = - Collections.List.split_at inputs body.arg_count - in - let args = List.combine inputs sg.inputs in - let args = - List.map - (fun (var, rty) -> var_to_string var ^ " : " ^ sty_to_string rty) - args - in - let args = String.concat ", " args in - - (* All the locals (with erased regions) *) - let locals = - List.map - (fun var -> - indent ^ indent_incr ^ var_to_string var ^ " : " - ^ ety_to_string var.var_ty ^ ";") - body.locals - in - let locals = String.concat "\n" locals in - - (* Body *) - let body = - statement_to_string fmt (indent ^ indent_incr) indent_incr body.body - in - - (* Put everything together *) - indent ^ "fn " ^ name ^ params ^ "(" ^ args ^ ")" ^ ret_ty ^ " {\n" - ^ locals ^ "\n\n" ^ body ^ "\n" ^ indent ^ "}" -end - -module PA = LlbcAst (* local module *) - -(** Pretty-printing for ASTs (functions based on a definition context) *) -module Module = struct - (** This function pretty-prints a type definition by using a definition - context *) - let type_decl_to_string (type_context : T.type_decl T.TypeDeclId.Map.t) - (def : T.type_decl) : string = - let type_decl_id_to_string (id : T.TypeDeclId.id) : string = - let def = T.TypeDeclId.Map.find id type_context in - name_to_string def.name - in - PT.type_decl_to_string type_decl_id_to_string def - - (** Generate an [ast_formatter] by using a definition context in combination - with the variables local to a function's definition *) - let def_ctx_to_ast_formatter (type_context : T.type_decl T.TypeDeclId.Map.t) - (fun_context : A.fun_decl A.FunDeclId.Map.t) - (global_context : A.global_decl A.GlobalDeclId.Map.t) (def : A.fun_decl) : - PA.ast_formatter = - let rvar_to_string vid = - let var = T.RegionVarId.nth def.signature.region_params vid in - PT.region_var_to_string var - in - let r_to_string vid = - (* TODO: we might want something more informative *) - PT.region_id_to_string vid - in - let type_var_id_to_string vid = - let var = T.TypeVarId.nth def.signature.type_params vid in - PT.type_var_to_string var - in - let type_decl_id_to_string def_id = - let def = T.TypeDeclId.Map.find def_id type_context in - name_to_string def.name - in - let fun_decl_id_to_string def_id = - let def = A.FunDeclId.Map.find def_id fun_context in - fun_name_to_string def.name - in - let global_decl_id_to_string def_id = - let def = A.GlobalDeclId.Map.find def_id global_context in - global_name_to_string def.name - in - let var_id_to_string vid = - let var = V.VarId.nth (Option.get def.body).locals vid in - PA.var_to_string var - in - let adt_variant_to_string = - PC.type_ctx_to_adt_variant_to_string_fun type_context - in - let adt_field_to_string = - PA.type_ctx_to_adt_field_to_string_fun type_context - in - let adt_field_names = PC.type_ctx_to_adt_field_names_fun type_context in - { - rvar_to_string; - r_to_string; - type_var_id_to_string; - type_decl_id_to_string; - adt_variant_to_string; - adt_field_to_string; - var_id_to_string; - adt_field_names; - fun_decl_id_to_string; - global_decl_id_to_string; - } - - (** This function pretty-prints a function definition by using a definition - context *) - let fun_decl_to_string (type_context : T.type_decl T.TypeDeclId.Map.t) - (fun_context : A.fun_decl A.FunDeclId.Map.t) - (global_context : A.global_decl A.GlobalDeclId.Map.t) (def : A.fun_decl) : - string = - let fmt = - def_ctx_to_ast_formatter type_context fun_context global_context def - in - PA.fun_decl_to_string fmt "" " " def - - let module_to_string (m : Crates.llbc_crate) : string = - let types_defs_map, funs_defs_map, globals_defs_map = - Crates.compute_defs_maps m - in - - (* The types *) - let type_decls = - List.map (type_decl_to_string types_defs_map) m.Crates.types - in - - (* The functions *) - let fun_decls = - List.map - (fun_decl_to_string types_defs_map funs_defs_map globals_defs_map) - m.Crates.functions - in - - (* Put everything together *) - let all_defs = List.append type_decls fun_decls in - String.concat "\n\n" all_defs -end - -(** Pretty-printing for LLBC ASTs (functions based on an evaluation context) *) -module EvalCtxLlbcAst = struct - let ety_to_string (ctx : C.eval_ctx) (t : T.ety) : string = - let fmt = PC.eval_ctx_to_ctx_formatter ctx in - let fmt = PC.ctx_to_etype_formatter fmt in - PT.ety_to_string fmt t - - let rty_to_string (ctx : C.eval_ctx) (t : T.rty) : string = - let fmt = PC.eval_ctx_to_ctx_formatter ctx in - let fmt = PC.ctx_to_rtype_formatter fmt in - PT.rty_to_string fmt t - - let borrow_content_to_string (ctx : C.eval_ctx) (bc : V.borrow_content) : - string = - let fmt = PC.eval_ctx_to_ctx_formatter ctx in - PV.borrow_content_to_string fmt bc - - let loan_content_to_string (ctx : C.eval_ctx) (lc : V.loan_content) : string = - let fmt = PC.eval_ctx_to_ctx_formatter ctx in - PV.loan_content_to_string fmt lc - - let aborrow_content_to_string (ctx : C.eval_ctx) (bc : V.aborrow_content) : - string = - let fmt = PC.eval_ctx_to_ctx_formatter ctx in - PV.aborrow_content_to_string fmt bc - - let aloan_content_to_string (ctx : C.eval_ctx) (lc : V.aloan_content) : string - = - let fmt = PC.eval_ctx_to_ctx_formatter ctx in - PV.aloan_content_to_string fmt lc - - let aproj_to_string (ctx : C.eval_ctx) (p : V.aproj) : string = - let fmt = PC.eval_ctx_to_ctx_formatter ctx in - PV.aproj_to_string fmt p - - let symbolic_value_to_string (ctx : C.eval_ctx) (sv : V.symbolic_value) : - string = - let fmt = PC.eval_ctx_to_ctx_formatter ctx in - let fmt = PC.ctx_to_rtype_formatter fmt in - PV.symbolic_value_to_string fmt sv - - let typed_value_to_string (ctx : C.eval_ctx) (v : V.typed_value) : string = - let fmt = PC.eval_ctx_to_ctx_formatter ctx in - PV.typed_value_to_string fmt v - - let typed_avalue_to_string (ctx : C.eval_ctx) (v : V.typed_avalue) : string = - let fmt = PC.eval_ctx_to_ctx_formatter ctx in - PV.typed_avalue_to_string fmt v - - let place_to_string (ctx : C.eval_ctx) (op : E.place) : string = - let fmt = PA.eval_ctx_to_ast_formatter ctx in - PA.place_to_string fmt op - - let operand_to_string (ctx : C.eval_ctx) (op : E.operand) : string = - let fmt = PA.eval_ctx_to_ast_formatter ctx in - PA.operand_to_string fmt op - - let statement_to_string (ctx : C.eval_ctx) (indent : string) - (indent_incr : string) (e : A.statement) : string = - let fmt = PA.eval_ctx_to_ast_formatter ctx in - PA.statement_to_string fmt indent indent_incr e -end diff --git a/src/PrintPure.ml b/src/PrintPure.ml deleted file mode 100644 index a9e42f6c..00000000 --- a/src/PrintPure.ml +++ /dev/null @@ -1,594 +0,0 @@ -(** This module defines printing functions for the types defined in Pure.ml *) - -open Pure -open PureUtils - -type type_formatter = { - type_var_id_to_string : TypeVarId.id -> string; - type_decl_id_to_string : TypeDeclId.id -> string; -} - -type value_formatter = { - type_var_id_to_string : TypeVarId.id -> string; - type_decl_id_to_string : TypeDeclId.id -> string; - adt_variant_to_string : TypeDeclId.id -> VariantId.id -> string; - var_id_to_string : VarId.id -> string; - adt_field_names : TypeDeclId.id -> VariantId.id option -> string list option; -} - -let value_to_type_formatter (fmt : value_formatter) : type_formatter = - { - type_var_id_to_string = fmt.type_var_id_to_string; - type_decl_id_to_string = fmt.type_decl_id_to_string; - } - -(* TODO: we need to store which variables we have encountered so far, and - remove [var_id_to_string]. -*) -type ast_formatter = { - type_var_id_to_string : TypeVarId.id -> string; - type_decl_id_to_string : TypeDeclId.id -> string; - adt_variant_to_string : TypeDeclId.id -> VariantId.id -> string; - var_id_to_string : VarId.id -> string; - adt_field_to_string : - TypeDeclId.id -> VariantId.id option -> FieldId.id -> string option; - adt_field_names : TypeDeclId.id -> VariantId.id option -> string list option; - fun_decl_id_to_string : FunDeclId.id -> string; - global_decl_id_to_string : GlobalDeclId.id -> string; -} - -let ast_to_value_formatter (fmt : ast_formatter) : value_formatter = - { - type_var_id_to_string = fmt.type_var_id_to_string; - type_decl_id_to_string = fmt.type_decl_id_to_string; - adt_variant_to_string = fmt.adt_variant_to_string; - var_id_to_string = fmt.var_id_to_string; - adt_field_names = fmt.adt_field_names; - } - -let ast_to_type_formatter (fmt : ast_formatter) : type_formatter = - let fmt = ast_to_value_formatter fmt in - value_to_type_formatter fmt - -let name_to_string = Print.name_to_string -let fun_name_to_string = Print.fun_name_to_string -let global_name_to_string = Print.global_name_to_string -let option_to_string = Print.option_to_string -let type_var_to_string = Print.Types.type_var_to_string -let integer_type_to_string = Print.Types.integer_type_to_string -let scalar_value_to_string = Print.Values.scalar_value_to_string - -let mk_type_formatter (type_decls : T.type_decl TypeDeclId.Map.t) - (type_params : type_var list) : type_formatter = - let type_var_id_to_string vid = - let var = T.TypeVarId.nth type_params vid in - type_var_to_string var - in - let type_decl_id_to_string def_id = - let def = T.TypeDeclId.Map.find def_id type_decls in - name_to_string def.name - in - { type_var_id_to_string; type_decl_id_to_string } - -(* TODO: there is a bit of duplication with Print.fun_decl_to_ast_formatter. - - TODO: use the pure defs as inputs? Note that it is a bit annoying for the - functions (there is a difference between the forward/backward functions...) - while we only need those definitions to lookup proper names for the def ids. -*) -let mk_ast_formatter (type_decls : T.type_decl TypeDeclId.Map.t) - (fun_decls : A.fun_decl FunDeclId.Map.t) - (global_decls : A.global_decl GlobalDeclId.Map.t) - (type_params : type_var list) : ast_formatter = - let type_var_id_to_string vid = - let var = T.TypeVarId.nth type_params vid in - type_var_to_string var - in - let type_decl_id_to_string def_id = - let def = T.TypeDeclId.Map.find def_id type_decls in - name_to_string def.name - in - let adt_variant_to_string = - Print.Contexts.type_ctx_to_adt_variant_to_string_fun type_decls - in - let var_id_to_string vid = - (* TODO: somehow lookup in the context *) - "^" ^ VarId.to_string vid - in - let adt_field_names = - Print.Contexts.type_ctx_to_adt_field_names_fun type_decls - in - let adt_field_to_string = - Print.LlbcAst.type_ctx_to_adt_field_to_string_fun type_decls - in - let fun_decl_id_to_string def_id = - let def = FunDeclId.Map.find def_id fun_decls in - fun_name_to_string def.name - in - let global_decl_id_to_string def_id = - let def = GlobalDeclId.Map.find def_id global_decls in - global_name_to_string def.name - in - { - type_var_id_to_string; - type_decl_id_to_string; - adt_variant_to_string; - var_id_to_string; - adt_field_names; - adt_field_to_string; - fun_decl_id_to_string; - global_decl_id_to_string; - } - -let type_id_to_string (fmt : type_formatter) (id : type_id) : string = - match id with - | AdtId id -> fmt.type_decl_id_to_string id - | Tuple -> "" - | Assumed aty -> ( - match aty with - | State -> "State" - | Result -> "Result" - | Option -> "Option" - | Vec -> "Vec") - -let rec ty_to_string (fmt : type_formatter) (ty : ty) : string = - match ty with - | Adt (id, tys) -> ( - let tys = List.map (ty_to_string fmt) tys in - match id with - | Tuple -> "(" ^ String.concat " * " tys ^ ")" - | AdtId _ | Assumed _ -> - let tys = if tys = [] then "" else " " ^ String.concat " " tys in - type_id_to_string fmt id ^ tys) - | TypeVar tv -> fmt.type_var_id_to_string tv - | Bool -> "bool" - | Char -> "char" - | Integer int_ty -> integer_type_to_string int_ty - | Str -> "str" - | Array aty -> "[" ^ ty_to_string fmt aty ^ "; ?]" - | Slice sty -> "[" ^ ty_to_string fmt sty ^ "]" - | Arrow (arg_ty, ret_ty) -> - ty_to_string fmt arg_ty ^ " -> " ^ ty_to_string fmt ret_ty - -let field_to_string fmt (f : field) : string = - match f.field_name with - | None -> ty_to_string fmt f.field_ty - | Some field_name -> field_name ^ " : " ^ ty_to_string fmt f.field_ty - -let variant_to_string fmt (v : variant) : string = - v.variant_name ^ "(" - ^ String.concat ", " (List.map (field_to_string fmt) v.fields) - ^ ")" - -let type_decl_to_string (fmt : type_formatter) (def : type_decl) : string = - let types = def.type_params in - let name = name_to_string def.name in - let params = - if types = [] then "" - else " " ^ String.concat " " (List.map type_var_to_string types) - in - match def.kind with - | Struct fields -> - if List.length fields > 0 then - let fields = - String.concat "," - (List.map (fun f -> "\n " ^ field_to_string fmt f) fields) - in - "struct " ^ name ^ params ^ "{" ^ fields ^ "}" - else "struct " ^ name ^ params ^ "{}" - | Enum variants -> - let variants = - List.map (fun v -> "| " ^ variant_to_string fmt v) variants - in - let variants = String.concat "\n" variants in - "enum " ^ name ^ params ^ " =\n" ^ variants - | Opaque -> "opaque type " ^ name ^ params - -let var_to_varname (v : var) : string = - match v.basename with - | Some name -> name ^ "^" ^ VarId.to_string v.id - | None -> "^" ^ VarId.to_string v.id - -let var_to_string (fmt : type_formatter) (v : var) : string = - let varname = var_to_varname v in - "(" ^ varname ^ " : " ^ ty_to_string fmt v.ty ^ ")" - -let rec mprojection_to_string (fmt : ast_formatter) (inside : string) - (p : mprojection) : string = - match p with - | [] -> inside - | pe :: p' -> ( - let s = mprojection_to_string fmt inside p' in - match pe.pkind with - | E.ProjOption variant_id -> - assert (variant_id = T.option_some_id); - assert (pe.field_id = T.FieldId.zero); - "(" ^ s ^ "as Option::Some)." ^ T.FieldId.to_string pe.field_id - | E.ProjTuple _ -> "(" ^ s ^ ")." ^ T.FieldId.to_string pe.field_id - | E.ProjAdt (adt_id, opt_variant_id) -> ( - let field_name = - match fmt.adt_field_to_string adt_id opt_variant_id pe.field_id with - | Some field_name -> field_name - | None -> T.FieldId.to_string pe.field_id - in - match opt_variant_id with - | None -> "(" ^ s ^ ")." ^ field_name - | Some variant_id -> - let variant_name = fmt.adt_variant_to_string adt_id variant_id in - "(" ^ s ^ " as " ^ variant_name ^ ")." ^ field_name)) - -let mplace_to_string (fmt : ast_formatter) (p : mplace) : string = - let name = match p.name with None -> "" | Some name -> name in - (* We add the "llbc" suffix to the variable index, because meta-places - * use indices of the variables in the original LLBC program, while - * regular places use indices for the pure variables: we want to make - * this explicit, otherwise it is confusing. *) - let name = name ^ "^" ^ V.VarId.to_string p.var_id ^ "llbc" in - mprojection_to_string fmt name p.projection - -let adt_variant_to_string (fmt : value_formatter) (adt_id : type_id) - (variant_id : VariantId.id option) : string = - match adt_id with - | Tuple -> "Tuple" - | AdtId def_id -> ( - (* "Regular" ADT *) - match variant_id with - | Some vid -> fmt.adt_variant_to_string def_id vid - | None -> fmt.type_decl_id_to_string def_id) - | Assumed aty -> ( - (* Assumed type *) - match aty with - | State -> - (* The [State] type is opaque: we can't get there *) - raise (Failure "Unreachable") - | Result -> - let variant_id = Option.get variant_id in - if variant_id = result_return_id then "@Result::Return" - else if variant_id = result_fail_id then "@Result::Fail" - else - raise (Failure "Unreachable: improper variant id for result type") - | Option -> - let variant_id = Option.get variant_id in - if variant_id = option_some_id then "@Option::Some " - else if variant_id = option_none_id then "@Option::None" - else - raise (Failure "Unreachable: improper variant id for result type") - | Vec -> - assert (variant_id = None); - "Vec") - -let adt_field_to_string (fmt : value_formatter) (adt_id : type_id) - (field_id : FieldId.id) : string = - match adt_id with - | Tuple -> - raise (Failure "Unreachable") - (* Tuples don't use the opaque field id for the field indices, but [int] *) - | AdtId def_id -> ( - (* "Regular" ADT *) - let fields = fmt.adt_field_names def_id None in - match fields with - | None -> FieldId.to_string field_id - | Some fields -> FieldId.nth fields field_id) - | Assumed aty -> ( - (* Assumed type *) - match aty with - | State | Vec -> - (* Opaque types: we can't get there *) - raise (Failure "Unreachable") - | Result | Option -> - (* Enumerations: we can't get there *) - raise (Failure "Unreachable")) - -(** TODO: we don't need a general function anymore (it is now only used for - patterns (i.e., patterns) - *) -let adt_g_value_to_string (fmt : value_formatter) - (value_to_string : 'v -> string) (variant_id : VariantId.id option) - (field_values : 'v list) (ty : ty) : string = - let field_values = List.map value_to_string field_values in - match ty with - | Adt (Tuple, _) -> - (* Tuple *) - "(" ^ String.concat ", " field_values ^ ")" - | Adt (AdtId def_id, _) -> - (* "Regular" ADT *) - let adt_ident = - match variant_id with - | Some vid -> fmt.adt_variant_to_string def_id vid - | None -> fmt.type_decl_id_to_string def_id - in - if field_values <> [] then - match fmt.adt_field_names def_id variant_id with - | None -> - let field_values = String.concat ", " field_values in - adt_ident ^ " (" ^ field_values ^ ")" - | Some field_names -> - let field_values = List.combine field_names field_values in - let field_values = - List.map - (fun (field, value) -> field ^ " = " ^ value ^ ";") - field_values - in - let field_values = String.concat " " field_values in - adt_ident ^ " { " ^ field_values ^ " }" - else adt_ident - | Adt (Assumed aty, _) -> ( - (* Assumed type *) - match aty with - | State -> - (* The [State] type is opaque: we can't get there *) - raise (Failure "Unreachable") - | Result -> - let variant_id = Option.get variant_id in - if variant_id = result_return_id then - match field_values with - | [ v ] -> "@Result::Return " ^ v - | _ -> raise (Failure "Result::Return takes exactly one value") - else if variant_id = result_fail_id then ( - assert (field_values = []); - "@Result::Fail") - else - raise (Failure "Unreachable: improper variant id for result type") - | Option -> - let variant_id = Option.get variant_id in - if variant_id = option_some_id then - match field_values with - | [ v ] -> "@Option::Some " ^ v - | _ -> raise (Failure "Option::Some takes exactly one value") - else if variant_id = option_none_id then ( - assert (field_values = []); - "@Option::None") - else - raise (Failure "Unreachable: improper variant id for result type") - | Vec -> - assert (variant_id = None); - let field_values = - List.mapi (fun i v -> string_of_int i ^ " -> " ^ v) field_values - in - "Vec [" ^ String.concat "; " field_values ^ "]") - | _ -> - let fmt = value_to_type_formatter fmt in - raise - (Failure - ("Inconsistently typed value: expected ADT type but found:" - ^ "\n- ty: " ^ ty_to_string fmt ty ^ "\n- variant_id: " - ^ Print.option_to_string VariantId.to_string variant_id)) - -let rec typed_pattern_to_string (fmt : ast_formatter) (v : typed_pattern) : - string = - match v.value with - | PatConcrete cv -> Print.Values.constant_value_to_string cv - | PatVar (v, None) -> var_to_string (ast_to_type_formatter fmt) v - | PatVar (v, Some mp) -> - let mp = "[@mplace=" ^ mplace_to_string fmt mp ^ "]" in - "(" ^ var_to_varname v ^ " " ^ mp ^ " : " - ^ ty_to_string (ast_to_type_formatter fmt) v.ty - ^ ")" - | PatDummy -> "_" - | PatAdt av -> - adt_g_value_to_string - (ast_to_value_formatter fmt) - (typed_pattern_to_string fmt) - av.variant_id av.field_values v.ty - -let fun_sig_to_string (fmt : ast_formatter) (sg : fun_sig) : string = - let ty_fmt = ast_to_type_formatter fmt in - let type_params = List.map type_var_to_string sg.type_params in - let inputs = List.map (ty_to_string ty_fmt) sg.inputs in - let output = ty_to_string ty_fmt sg.output in - let all_types = List.concat [ type_params; inputs; [ output ] ] in - String.concat " -> " all_types - -let inst_fun_sig_to_string (fmt : ast_formatter) (sg : inst_fun_sig) : string = - let ty_fmt = ast_to_type_formatter fmt in - let inputs = List.map (ty_to_string ty_fmt) sg.inputs in - let output = ty_to_string ty_fmt sg.output in - let all_types = List.append inputs [ output ] in - String.concat " -> " all_types - -let regular_fun_id_to_string (fmt : ast_formatter) (fun_id : A.fun_id) : string - = - match fun_id with - | A.Regular fid -> fmt.fun_decl_id_to_string fid - | A.Assumed fid -> ( - match fid with - | A.Replace -> "core::mem::replace" - | A.BoxNew -> "alloc::boxed::Box::new" - | A.BoxDeref -> "core::ops::deref::Deref::deref" - | A.BoxDerefMut -> "core::ops::deref::DerefMut::deref_mut" - | A.BoxFree -> "alloc::alloc::box_free" - | A.VecNew -> "alloc::vec::Vec::new" - | A.VecPush -> "alloc::vec::Vec::push" - | A.VecInsert -> "alloc::vec::Vec::insert" - | A.VecLen -> "alloc::vec::Vec::len" - | A.VecIndex -> "core::ops::index::Index::index" - | A.VecIndexMut -> - "core::ops::index::IndexMut::index_mut") - -let fun_suffix (rg_id : T.RegionGroupId.id option) : string = - match rg_id with - | None -> "" - | Some rg_id -> "@" ^ T.RegionGroupId.to_string rg_id - -let unop_to_string (unop : unop) : string = - match unop with - | Not -> "¬" - | Neg _ -> "-" - | Cast (src, tgt) -> - "cast<" ^ integer_type_to_string src ^ "," ^ integer_type_to_string tgt - ^ ">" - -let binop_to_string = Print.LlbcAst.binop_to_string - -let fun_id_to_string (fmt : ast_formatter) (fun_id : fun_id) : string = - match fun_id with - | Regular (fun_id, rg_id) -> - let f = regular_fun_id_to_string fmt fun_id in - f ^ fun_suffix rg_id - | Unop unop -> unop_to_string unop - | Binop (binop, int_ty) -> - binop_to_string binop ^ "<" ^ integer_type_to_string int_ty ^ ">" - -(** [inside]: controls the introduction of parentheses *) -let rec texpression_to_string (fmt : ast_formatter) (inside : bool) - (indent : string) (indent_incr : string) (e : texpression) : string = - match e.e with - | Var var_id -> - let s = fmt.var_id_to_string var_id in - if inside then "(" ^ s ^ ")" else s - | Const cv -> Print.Values.constant_value_to_string cv - | App _ -> - (* Recursively destruct the app, to have a pair (app, arguments list) *) - let app, args = destruct_apps e in - (* Convert to string *) - app_to_string fmt inside indent indent_incr app args - | Abs _ -> - let xl, e = destruct_abs_list e in - let e = abs_to_string fmt indent indent_incr xl e in - if inside then "(" ^ e ^ ")" else e - | Qualif _ -> - (* Qualifier without arguments *) - app_to_string fmt inside indent indent_incr e [] - | Let (monadic, lv, re, e) -> - let e = let_to_string fmt indent indent_incr monadic lv re e in - if inside then "(" ^ e ^ ")" else e - | Switch (scrutinee, body) -> - let e = switch_to_string fmt indent indent_incr scrutinee body in - if inside then "(" ^ e ^ ")" else e - | Meta (meta, e) -> ( - let meta_s = meta_to_string fmt meta in - let e = texpression_to_string fmt inside indent indent_incr e in - match meta with - | Assignment _ -> - let e = meta_s ^ "\n" ^ indent ^ e in - if inside then "(" ^ e ^ ")" else e - | MPlace _ -> "(" ^ meta_s ^ " " ^ e ^ ")") - -and app_to_string (fmt : ast_formatter) (inside : bool) (indent : string) - (indent_incr : string) (app : texpression) (args : texpression list) : - string = - (* There are two possibilities: either the [app] is an instantiated, - * top-level qualifier (function, ADT constructore...), or it is a "regular" - * expression *) - let app, tys = - match app.e with - | Qualif qualif -> - (* Qualifier case *) - (* Convert the qualifier identifier *) - let qualif_s = - match qualif.id with - | Func fun_id -> fun_id_to_string fmt fun_id - | Global global_id -> fmt.global_decl_id_to_string global_id - | AdtCons adt_cons_id -> - let variant_s = - adt_variant_to_string - (ast_to_value_formatter fmt) - adt_cons_id.adt_id adt_cons_id.variant_id - in - ConstStrings.constructor_prefix ^ variant_s - | Proj { adt_id; field_id } -> - let value_fmt = ast_to_value_formatter fmt in - let adt_s = adt_variant_to_string value_fmt adt_id None in - let field_s = adt_field_to_string value_fmt adt_id field_id in - (* Adopting an F*-like syntax *) - ConstStrings.constructor_prefix ^ adt_s ^ "?." ^ field_s - in - (* Convert the type instantiation *) - let ty_fmt = ast_to_type_formatter fmt in - let tys = List.map (ty_to_string ty_fmt) qualif.type_args in - (* *) - (qualif_s, tys) - | _ -> - (* "Regular" expression case *) - let inside = args <> [] || (args = [] && inside) in - (texpression_to_string fmt inside indent indent_incr app, []) - in - (* Convert the arguments. - * The arguments are expressions, so indentation might get weird... (though - * those expressions will in most cases just be values) *) - let arg_to_string = - let inside = true in - let indent1 = indent ^ indent_incr in - texpression_to_string fmt inside indent1 indent_incr - in - let args = List.map arg_to_string args in - let all_args = List.append tys args in - (* Put together *) - let e = - if all_args = [] then app else app ^ " " ^ String.concat " " all_args - in - (* Add parentheses *) - if all_args <> [] && inside then "(" ^ e ^ ")" else e - -and abs_to_string (fmt : ast_formatter) (indent : string) (indent_incr : string) - (xl : typed_pattern list) (e : texpression) : string = - let xl = List.map (typed_pattern_to_string fmt) xl in - let e = texpression_to_string fmt false indent indent_incr e in - "λ " ^ String.concat " " xl ^ ". " ^ e - -and let_to_string (fmt : ast_formatter) (indent : string) (indent_incr : string) - (monadic : bool) (lv : typed_pattern) (re : texpression) (e : texpression) : - string = - let indent1 = indent ^ indent_incr in - let inside = false in - let re = texpression_to_string fmt inside indent1 indent_incr re in - let e = texpression_to_string fmt inside indent indent_incr e in - let lv = typed_pattern_to_string fmt lv in - if monadic then lv ^ " <-- " ^ re ^ ";\n" ^ indent ^ e - else "let " ^ lv ^ " = " ^ re ^ " in\n" ^ indent ^ e - -and switch_to_string (fmt : ast_formatter) (indent : string) - (indent_incr : string) (scrutinee : texpression) (body : switch_body) : - string = - let indent1 = indent ^ indent_incr in - (* Printing can mess up on the scrutinee, because it is an expression - but - * in most situations it will be a value or a function call, so it should be - * ok*) - let scrut = texpression_to_string fmt true indent1 indent_incr scrutinee in - let e_to_string = texpression_to_string fmt false indent1 indent_incr in - match body with - | If (e_true, e_false) -> - let e_true = e_to_string e_true in - let e_false = e_to_string e_false in - "if " ^ scrut ^ "\n" ^ indent ^ "then\n" ^ indent1 ^ e_true ^ "\n" - ^ indent ^ "else\n" ^ indent1 ^ e_false - | Match branches -> - let branch_to_string (b : match_branch) : string = - let pat = typed_pattern_to_string fmt b.pat in - indent ^ "| " ^ pat ^ " ->\n" ^ indent1 ^ e_to_string b.branch - in - let branches = List.map branch_to_string branches in - "match " ^ scrut ^ " with\n" ^ String.concat "\n" branches - -and meta_to_string (fmt : ast_formatter) (meta : meta) : string = - let meta = - match meta with - | Assignment (lp, rv, rp) -> - let rp = - match rp with - | None -> "" - | Some rp -> " [@src=" ^ mplace_to_string fmt rp ^ "]" - in - "@assign(" ^ mplace_to_string fmt lp ^ " := " - ^ texpression_to_string fmt false "" "" rv - ^ rp ^ ")" - | MPlace mp -> "@mplace=" ^ mplace_to_string fmt mp - in - "@meta[" ^ meta ^ "]" - -let fun_decl_to_string (fmt : ast_formatter) (def : fun_decl) : string = - let type_fmt = ast_to_type_formatter fmt in - let name = fun_name_to_string def.basename ^ fun_suffix def.back_id in - let signature = fun_sig_to_string fmt def.signature in - match def.body with - | None -> "val " ^ name ^ " :\n " ^ signature - | Some body -> - let inside = false in - let indent = " " in - let inputs = List.map (var_to_string type_fmt) body.inputs in - let inputs = - if inputs = [] then indent - else " fun " ^ String.concat " " inputs ^ " ->\n" ^ indent - in - let body = texpression_to_string fmt inside indent indent body.body in - "let " ^ name ^ " :\n " ^ signature ^ " =\n" ^ inputs ^ body diff --git a/src/Pure.ml b/src/Pure.ml deleted file mode 100644 index 77265f75..00000000 --- a/src/Pure.ml +++ /dev/null @@ -1,581 +0,0 @@ -open Identifiers -open Names -module T = Types -module V = Values -module E = Expressions -module A = LlbcAst -module TypeDeclId = T.TypeDeclId -module TypeVarId = T.TypeVarId -module RegionGroupId = T.RegionGroupId -module VariantId = T.VariantId -module FieldId = T.FieldId -module SymbolicValueId = V.SymbolicValueId -module FunDeclId = A.FunDeclId -module GlobalDeclId = A.GlobalDeclId - -(** We give an identifier to every phase of the synthesis (forward, backward - for group of regions 0, etc.) *) -module SynthPhaseId = IdGen () - -(** Pay attention to the fact that we also define a {!Values.VarId} module in Values *) -module VarId = IdGen () - -type integer_type = T.integer_type [@@deriving show, ord] - -(** The assumed types for the pure AST. - - In comparison with LLBC: - - we removed [Box] (because it is translated as the identity: [Box T == T]) - - we added: - - [Result]: the type used in the error monad. This allows us to have a - unified treatment of expressions (especially when we have to unfold the - monadic binds) - - [State]: the type of the state, when using state-error monads. Note that - this state is opaque to Aeneas (the user can define it, or leave it as - assumed) - *) -type assumed_ty = State | Result | Vec | Option [@@deriving show, ord] - -(* TODO: we should never directly manipulate [Return] and [Fail], but rather - * the monadic functions [return] and [fail] (makes treatment of error and - * state-error monads more uniform) *) -let result_return_id = VariantId.of_int 0 -let result_fail_id = VariantId.of_int 1 -let option_some_id = T.option_some_id -let option_none_id = T.option_none_id - -type type_id = AdtId of TypeDeclId.id | Tuple | Assumed of assumed_ty -[@@deriving show, ord] - -(** Ancestor for iter visitor for [ty] *) -class ['self] iter_ty_base = - object (_self : 'self) - inherit [_] VisitorsRuntime.iter - method visit_id : 'env -> TypeVarId.id -> unit = fun _ _ -> () - method visit_type_id : 'env -> type_id -> unit = fun _ _ -> () - method visit_integer_type : 'env -> integer_type -> unit = fun _ _ -> () - end - -(** Ancestor for map visitor for [ty] *) -class ['self] map_ty_base = - object (_self : 'self) - inherit [_] VisitorsRuntime.map - method visit_id : 'env -> TypeVarId.id -> TypeVarId.id = fun _ id -> id - method visit_type_id : 'env -> type_id -> type_id = fun _ id -> id - - method visit_integer_type : 'env -> integer_type -> integer_type = - fun _ ity -> ity - end - -type ty = - | Adt of type_id * ty list - (** {!Adt} encodes ADTs and tuples and assumed types. - - TODO: what about the ended regions? (ADTs may be parameterized - with several region variables. When giving back an ADT value, we may - be able to only give back part of the ADT. We need a way to encode - such "partial" ADTs. - *) - | TypeVar of TypeVarId.id - | Bool - | Char - | Integer of integer_type - | Str - | Array of ty (* TODO: this should be an assumed type?... *) - | Slice of ty (* TODO: this should be an assumed type?... *) - | Arrow of ty * ty -[@@deriving - show, - visitors - { - name = "iter_ty"; - variety = "iter"; - ancestors = [ "iter_ty_base" ]; - nude = true (* Don't inherit {!VisitorsRuntime.iter} *); - concrete = true; - polymorphic = false; - }, - visitors - { - name = "map_ty"; - variety = "map"; - ancestors = [ "map_ty_base" ]; - nude = true (* Don't inherit {!VisitorsRuntime.iter} *); - concrete = true; - polymorphic = false; - }] - -type field = { field_name : string option; field_ty : ty } [@@deriving show] -type variant = { variant_name : string; fields : field list } [@@deriving show] - -type type_decl_kind = Struct of field list | Enum of variant list | Opaque -[@@deriving show] - -type type_var = T.type_var [@@deriving show] - -type type_decl = { - def_id : TypeDeclId.id; - name : name; - type_params : type_var list; - kind : type_decl_kind; -} -[@@deriving show] - -type scalar_value = V.scalar_value [@@deriving show] -type constant_value = V.constant_value [@@deriving show] - -(** Because we introduce a lot of temporary variables, the list of variables - is not fixed: we thus must carry all its information with the variable - itself. - *) -type var = { - id : VarId.id; - basename : string option; - (** The "basename" is used to generate a meaningful name for the variable - (by potentially adding an index to uniquely identify it). - *) - ty : ty; -} -[@@deriving show] - -(* TODO: we might want to redefine field_proj_kind here, to prevent field accesses - * on enumerations. - * Also: tuples... - * Rmk: projections are actually only used as meta-data. - * *) -type mprojection_elem = { pkind : E.field_proj_kind; field_id : FieldId.id } -[@@deriving show] - -type mprojection = mprojection_elem list [@@deriving show] - -(** "Meta" place. - - Meta-data retrieved from the symbolic execution, which gives provenance - information about the values. We use this to generate names for the variables - we introduce. - *) -type mplace = { - var_id : V.VarId.id; - name : string option; - projection : mprojection; -} -[@@deriving show] - -type variant_id = VariantId.id [@@deriving show] - -(** Ancestor for [iter_pat_var_or_dummy] visitor *) -class ['self] iter_value_base = - object (_self : 'self) - inherit [_] VisitorsRuntime.iter - method visit_constant_value : 'env -> constant_value -> unit = fun _ _ -> () - method visit_var : 'env -> var -> unit = fun _ _ -> () - method visit_mplace : 'env -> mplace -> unit = fun _ _ -> () - method visit_ty : 'env -> ty -> unit = fun _ _ -> () - method visit_variant_id : 'env -> variant_id -> unit = fun _ _ -> () - end - -(** Ancestor for [map_typed_rvalue] visitor *) -class ['self] map_value_base = - object (_self : 'self) - inherit [_] VisitorsRuntime.map - - method visit_constant_value : 'env -> constant_value -> constant_value = - fun _ x -> x - - method visit_var : 'env -> var -> var = fun _ x -> x - method visit_mplace : 'env -> mplace -> mplace = fun _ x -> x - method visit_ty : 'env -> ty -> ty = fun _ x -> x - method visit_variant_id : 'env -> variant_id -> variant_id = fun _ x -> x - end - -(** Ancestor for [reduce_typed_rvalue] visitor *) -class virtual ['self] reduce_value_base = - object (self : 'self) - inherit [_] VisitorsRuntime.reduce - - method visit_constant_value : 'env -> constant_value -> 'a = - fun _ _ -> self#zero - - method visit_var : 'env -> var -> 'a = fun _ _ -> self#zero - method visit_mplace : 'env -> mplace -> 'a = fun _ _ -> self#zero - method visit_ty : 'env -> ty -> 'a = fun _ _ -> self#zero - method visit_variant_id : 'env -> variant_id -> 'a = fun _ _ -> self#zero - end - -(** Ancestor for [mapreduce_typed_rvalue] visitor *) -class virtual ['self] mapreduce_value_base = - object (self : 'self) - inherit [_] VisitorsRuntime.mapreduce - - method visit_constant_value : 'env -> constant_value -> constant_value * 'a - = - fun _ x -> (x, self#zero) - - method visit_var : 'env -> var -> var * 'a = fun _ x -> (x, self#zero) - - method visit_mplace : 'env -> mplace -> mplace * 'a = - fun _ x -> (x, self#zero) - - method visit_ty : 'env -> ty -> ty * 'a = fun _ x -> (x, self#zero) - - method visit_variant_id : 'env -> variant_id -> variant_id * 'a = - fun _ x -> (x, self#zero) - end - -(** A pattern (which appears on the left of assignments, in matches, etc.). *) -type pattern = - | PatConcrete of constant_value - (** {!PatConcrete} is necessary because we merge the switches over integer - values and the matches over enumerations *) - | PatVar of var * mplace option - | PatDummy (** Ignored value: [_]. *) - | PatAdt of adt_pattern - -and adt_pattern = { - variant_id : variant_id option; - field_values : typed_pattern list; -} - -and typed_pattern = { value : pattern; ty : ty } -[@@deriving - show, - visitors - { - name = "iter_typed_pattern"; - variety = "iter"; - ancestors = [ "iter_value_base" ]; - nude = true (* Don't inherit {!VisitorsRuntime.iter} *); - concrete = true; - polymorphic = false; - }, - visitors - { - name = "map_typed_pattern"; - variety = "map"; - ancestors = [ "map_value_base" ]; - nude = true (* Don't inherit {!VisitorsRuntime.iter} *); - concrete = true; - polymorphic = false; - }, - visitors - { - name = "reduce_typed_pattern"; - variety = "reduce"; - ancestors = [ "reduce_value_base" ]; - nude = true (* Don't inherit {!VisitorsRuntime.iter} *); - polymorphic = false; - }, - visitors - { - name = "mapreduce_typed_pattern"; - variety = "mapreduce"; - ancestors = [ "mapreduce_value_base" ]; - nude = true (* Don't inherit {!VisitorsRuntime.iter} *); - polymorphic = false; - }] - -type unop = Not | Neg of integer_type | Cast of integer_type * integer_type -[@@deriving show, ord] - -type fun_id = - | Regular of A.fun_id * T.RegionGroupId.id option - (** Backward id: [Some] if the function is a backward function, [None] - if it is a forward function. - - TODO: we need to redefine A.fun_id here, to add [fail] and - [return] (important to get a unified treatment of the state-error - monad). For now, when using the state-error monad: extraction - works only if we unfold all the monadic let-bindings, and we - then replace the content of the occurrences of [Return] to also - return the state (which is really super ugly). - *) - | Unop of unop - | Binop of E.binop * integer_type -[@@deriving show, ord] - -(** An identifier for an ADT constructor *) -type adt_cons_id = { adt_id : type_id; variant_id : variant_id option } -[@@deriving show] - -(** Projection - For now we don't support projection of tuple fields - (because not all the backends have syntax for this). - *) -type projection = { adt_id : type_id; field_id : FieldId.id } [@@deriving show] - -type qualif_id = - | Func of fun_id - | Global of GlobalDeclId.id - | AdtCons of adt_cons_id (** A function or ADT constructor identifier *) - | Proj of projection (** Field projector *) -[@@deriving show] - -(** An instantiated qualified. - - Note that for now we have a clear separation between types and expressions, - which explains why we have the [type_params] field: a function or ADT - constructor is always fully instantiated. - *) -type qualif = { id : qualif_id; type_args : ty list } [@@deriving show] - -type var_id = VarId.id [@@deriving show] - -(** Ancestor for [iter_expression] visitor *) -class ['self] iter_expression_base = - object (_self : 'self) - inherit [_] iter_typed_pattern - method visit_integer_type : 'env -> integer_type -> unit = fun _ _ -> () - method visit_var_id : 'env -> var_id -> unit = fun _ _ -> () - method visit_qualif : 'env -> qualif -> unit = fun _ _ -> () - end - -(** Ancestor for [map_expression] visitor *) -class ['self] map_expression_base = - object (_self : 'self) - inherit [_] map_typed_pattern - - method visit_integer_type : 'env -> integer_type -> integer_type = - fun _ x -> x - - method visit_var_id : 'env -> var_id -> var_id = fun _ x -> x - method visit_qualif : 'env -> qualif -> qualif = fun _ x -> x - end - -(** Ancestor for [reduce_expression] visitor *) -class virtual ['self] reduce_expression_base = - object (self : 'self) - inherit [_] reduce_typed_pattern - - method visit_integer_type : 'env -> integer_type -> 'a = - fun _ _ -> self#zero - - method visit_var_id : 'env -> var_id -> 'a = fun _ _ -> self#zero - method visit_qualif : 'env -> qualif -> 'a = fun _ _ -> self#zero - end - -(** Ancestor for [mapreduce_expression] visitor *) -class virtual ['self] mapreduce_expression_base = - object (self : 'self) - inherit [_] mapreduce_typed_pattern - - method visit_integer_type : 'env -> integer_type -> integer_type * 'a = - fun _ x -> (x, self#zero) - - method visit_var_id : 'env -> var_id -> var_id * 'a = - fun _ x -> (x, self#zero) - - method visit_qualif : 'env -> qualif -> qualif * 'a = - fun _ x -> (x, self#zero) - end - -(** **Rk.:** here, {!expression} is not at all equivalent to the expressions - used in LLBC. They are lambda-calculus expressions, and are thus actually - more general than the LLBC statements, in a sense. - *) -type expression = - | Var of var_id (** a variable *) - | Const of constant_value - | App of texpression * texpression - (** Application of a function to an argument. - - The function calls are still quite structured. - Change that?... We might want to have a "normal" lambda calculus - app (with head and argument): this would allow us to replace some - field accesses with calls to projectors over fields (when there - are clashes of field names, some provers like F* get pretty bad...) - *) - | Abs of typed_pattern * texpression (** Lambda abstraction: [fun x -> e] *) - | Qualif of qualif (** A top-level qualifier *) - | Let of bool * typed_pattern * texpression * texpression - (** Let binding. - - TODO: the boolean should be replaced by an enum: sometimes we use - the error-monad, sometimes we use the state-error monad (and we - do this an a per-function basis! For instance, arithmetic functions - are always in the error monad). - - The boolean controls whether the let is monadic or not. - For instance, in F*: - - non-monadic: [let x = ... in ...] - - monadic: [x <-- ...; ...] - - Note that we are quite general for the left-value on purpose; this - is used in several situations: - - 1. When deconstructing a tuple: - {[ - let (x, y) = p in ... - ]} - (not all languages have syntax like [p.0], [p.1]... and it is more - readable anyway). - - 2. When expanding an enumeration with one variant. - In this case, {!Let} has to be understood as: - {[ - let Cons x tl = ls in - ... - ]} - - Note that later, depending on the language we extract to, we can - eventually update it to something like this (for F*, for instance): - {[ - let x = Cons?.v ls in - let tl = Cons?.tl ls in - ... - ]} - *) - | Switch of texpression * switch_body - | Meta of (meta[@opaque]) * texpression (** Meta-information *) - -and switch_body = If of texpression * texpression | Match of match_branch list -and match_branch = { pat : typed_pattern; branch : texpression } -and texpression = { e : expression; ty : ty } - -(** Meta-value (converted to an expression). It is important that the content - is opaque. - - TODO: is it possible to mark the whole mvalue type as opaque? - *) -and mvalue = (texpression[@opaque]) - -and meta = - | Assignment of mplace * mvalue * mplace option - (** Meta-information stored in the AST. - - The first mplace stores the destination. - The mvalue stores the value which is put in the destination - The second (optional) mplace stores the origin. - *) - | MPlace of mplace (** Meta-information about the origin of a value *) -[@@deriving - show, - visitors - { - name = "iter_expression"; - variety = "iter"; - ancestors = [ "iter_expression_base" ]; - nude = true (* Don't inherit {!VisitorsRuntime.iter} *); - concrete = true; - }, - visitors - { - name = "map_expression"; - variety = "map"; - ancestors = [ "map_expression_base" ]; - nude = true (* Don't inherit {!VisitorsRuntime.iter} *); - concrete = true; - }, - visitors - { - name = "reduce_expression"; - variety = "reduce"; - ancestors = [ "reduce_expression_base" ]; - nude = true (* Don't inherit {!VisitorsRuntime.iter} *); - }, - visitors - { - name = "mapreduce_expression"; - variety = "mapreduce"; - ancestors = [ "mapreduce_expression_base" ]; - nude = true (* Don't inherit {!VisitorsRuntime.iter} *); - }] - -(** Information about the "effect" of a function *) -type fun_effect_info = { - input_state : bool; (** [true] if the function takes a state as input *) - output_state : bool; - (** [true] if the function outputs a state (it then lives - in a state monad) *) - can_fail : bool; (** [true] if the return type is a [result] *) -} - -(** Meta information about a function signature *) -type fun_sig_info = { - num_fwd_inputs : int; - (** The number of input types for forward computation *) - num_back_inputs : int option; - (** The number of additional inputs for the backward computation (if pertinent) *) - effect_info : fun_effect_info; -} - -(** A function signature. - - We have the following cases: - - forward function: - [in_ty0 -> ... -> in_tyn -> out_ty] (* pure function *) - `in_ty0 -> ... -> in_tyn -> result out_ty` (* error-monad *) - `in_ty0 -> ... -> in_tyn -> state -> result (state & out_ty)` (* state-error *) - - backward function: - `in_ty0 -> ... -> in_tyn -> back_in0 -> ... back_inm -> (back_out0 & ... & back_outp)` (* pure function *) - `in_ty0 -> ... -> in_tyn -> back_in0 -> ... back_inm -> - result (back_out0 & ... & back_outp)` (* error-monad *) - `in_ty0 -> ... -> in_tyn -> state -> back_in0 -> ... back_inm -> - result (back_out0 & ... & back_outp)` (* state-error *) - - Note that a backward function never returns (i.e., updates) a state: only - forward functions do so. Also, the state input parameter is *betwee* - the forward inputs and the backward inputs. - - The function's type should be given by `mk_arrows sig.inputs sig.output`. - We provide additional meta-information: - - we divide between forward inputs and backward inputs (i.e., inputs specific - to the forward functions, and additional inputs necessary if the signature is - for a backward function) - - we have booleans to give us the fact that the function takes a state as - input, or can fail, etc. without having to inspect the signature - - etc. - *) -type fun_sig = { - type_params : type_var list; - inputs : ty list; - output : ty; - doutputs : ty list; - (** The "decomposed" list of outputs. - - In case of a forward function, the list has length = 1, for the - type of the returned value. - - In case of backward function, the list contains all the types of - all the given back values (there is at most one type per forward - input argument). - - Ex.: - {[ - fn choose<'a, T>(b : bool, x : &'a mut T, y : &'a mut T) -> &'a mut T; - ]} - Decomposed outputs: - - forward function: [T] - - backward function: [T; T] (for "x" and "y") - - *) - info : fun_sig_info; (** Additional information *) -} - -(** An instantiated function signature. See {!fun_sig} *) -type inst_fun_sig = { - inputs : ty list; - output : ty; - doutputs : ty list; - info : fun_sig_info; -} - -type fun_body = { - inputs : var list; - inputs_lvs : typed_pattern list; - (** The inputs seen as patterns. Allows to make transformations, for example - to replace unused variables by [_] *) - body : texpression; -} - -type fun_decl = { - def_id : FunDeclId.id; - back_id : T.RegionGroupId.id option; - basename : fun_name; - (** The "base" name of the function. - - The base name is the original name of the Rust function. We add suffixes - (to identify the forward/backward functions) later. - *) - signature : fun_sig; - is_global_decl_body : bool; - body : fun_body option; -} diff --git a/src/PureMicroPasses.ml b/src/PureMicroPasses.ml deleted file mode 100644 index 3edae38a..00000000 --- a/src/PureMicroPasses.ml +++ /dev/null @@ -1,1375 +0,0 @@ -(** The following module defines micro-passes which operate on the pure AST *) - -open Pure -open PureUtils -open TranslateCore -module V = Values - -(** The local logger *) -let log = L.pure_micro_passes_log - -(** A configuration to control the application of the passes *) -type config = { - decompose_monadic_let_bindings : bool; - (** Some provers like F* don't support the decomposition of return values - in monadic let-bindings: - {[ - // NOT supported in F* - let (x, y) <-- f (); - ... - ]} - - In such situations, we might want to introduce an intermediate - assignment: - {[ - let tmp <-- f (); - let (x, y) = tmp in - ... - ]} - *) - unfold_monadic_let_bindings : bool; - (** Controls the unfolding of monadic let-bindings to explicit matches: - - [y <-- f x; ...] - - becomes: - - [match f x with | Failure -> Failure | Return y -> ...] - - - This is useful when extracting to F*: the support for monadic - definitions is not super powerful. - Note that when {!field:unfold_monadic_let_bindings} is true, setting - {!field:decompose_monadic_let_bindings} to true and only makes the code - more verbose. - *) - filter_useless_monadic_calls : bool; - (** Controls whether we try to filter the calls to monadic functions - (which can fail) when their outputs are not used. - - See the comments for {!expression_contains_child_call_in_all_paths} - for additional explanations. - - TODO: rename to {!filter_useless_monadic_calls} - *) - filter_useless_functions : bool; - (** If {!filter_useless_monadic_calls} is activated, some functions - become useless: if this option is true, we don't extract them. - - The calls to functions which always get filtered are: - - the forward functions with unit return value - - the backward functions which don't output anything (backward - functions coming from rust functions with no mutable borrows - as input values - note that if a function doesn't take mutable - borrows as inputs, it can't return mutable borrows; we actually - dynamically check for that). - *) -} - -(** Small utility. - - We sometimes have to insert new fresh variables in a function body, in which - case we need to make their indices greater than the indices of all the variables - in the body. - TODO: things would be simpler if we used a better representation of the - variables indices... - *) -let get_body_min_var_counter (body : fun_body) : VarId.generator = - (* Find the max id in the input variables - some of them may have been - * filtered from the body *) - let min_input_id = - List.fold_left - (fun id (var : var) -> VarId.max id var.id) - VarId.zero body.inputs - in - let obj = - object - inherit [_] reduce_expression - method zero _ = min_input_id - method plus id0 id1 _ = VarId.max (id0 ()) (id1 ()) - (* Get the maximum *) - - (** For the patterns *) - method! visit_var _ v _ = v.id - - (** For the rvalues *) - method! visit_Var _ vid _ = vid - end - in - (* Find the max counter in the body *) - let id = obj#visit_expression () body.body.e () in - VarId.generator_from_incr_id id - -(** "pretty-name context": see [compute_pretty_names] *) -type pn_ctx = { - pure_vars : string VarId.Map.t; - (** Information about the pure variables used in the synthesized program *) - llbc_vars : string V.VarId.Map.t; - (** Information about the LLBC variables used in the original program *) -} - -(** This function computes pretty names for the variables in the pure AST. It - relies on the "meta"-place information in the AST to generate naming - constraints, and then uses those to compute the names. - - The way it works is as follows: - - we only modify the names of the unnamed variables - - whenever we see an rvalue/pattern which is exactly an unnamed variable, - and this value is linked to some meta-place information which contains - a name and an empty path, we consider we should use this name - - we try to propagate naming constraints on the pure variables use in the - synthesized programs, and also on the LLBC variables from the original - program (information about the LLBC variables is stored in the meta-places) - - - Something important is that, for every variable we find, the name of this - variable can be influenced by the information we find *below* in the AST. - - For instance, the following situations happen: - - - let's say we evaluate: - {[ - match (ls : List) { - List::Cons(x, hd) => { - ... - } - } - ]} - - Actually, in MIR, we get: - {[ - tmp := discriminant(ls); - switch tmp { - 0 => { - x := (ls as Cons).0; // (i) - hd := (ls as Cons).1; // (ii) - ... - } - } - ]} - If [ls] maps to a symbolic value [s0] upon evaluating the match in symbolic - mode, we expand this value upon evaluating [tmp = discriminant(ls)]. - However, at this point, we don't know which should be the names of - the symbolic values we introduce for the fields of [Cons]! - - Let's imagine we have (for the [Cons] branch): [s0 ~~> Cons s1 s2]. - The assigments at (i) and (ii) lead to the following binding in the - evaluation context: - {[ - x -> s1 - hd -> s2 - ]} - - When generating the symbolic AST, we save as meta-information that we - assign [s1] to the place [x] and [s2] to the place [hd]. This way, - we learn we can use the names [x] and [hd] for the variables which are - introduced by the match: - {[ - match ls with - | Cons x hd -> ... - | ... - ]} - - Assignments: - [let x [@mplace=lp] = v [@mplace = rp] in ...] - - We propagate naming information across the assignments. This is important - because many reassignments using temporary, anonymous variables are - introduced during desugaring. - - - Given back values (introduced by backward functions): - Let's say we have the following Rust code: - {[ - let py = id(&mut x); - *py = 2; - assert!(x == 2); - ]} - - After desugaring, we get the following MIR: - {[ - ^0 = &mut x; // anonymous variable - py = id(move ^0); - *py += 2; - assert!(x == 2); - ]} - - We want this to be translated as: - {[ - let py = id_fwd x in - let py1 = py + 2 in - let x1 = id_back x py1 in // <-- x1 is "given back": doesn't appear in the original MIR - assert(x1 = 2); - ]} - - We want to notice that the value given back by [id_back] is given back for "x", - so we should use "x" as the basename (hence the resulting name "x1"). However, - this is non-trivial, because after desugaring the input argument given to [id] - is not [&mut x] but [move ^0] (i.e., it comes from a temporary, anonymous - variable). For this reason, we use the meta-place [&mut x] as the meta-place - for the given back value (this is done during the synthesis), and propagate - naming information *also* on the LLBC variables (which are referenced by the - meta-places). - - This way, because of [^0 = &mut x], we can propagate the name "x" to the place - [^0], then to the given back variable across the function call. - - *) -let compute_pretty_names (def : fun_decl) : fun_decl = - (* Small helpers *) - (* - * When we do branchings, we need to merge (the constraints saved in) the - * contexts returned by the different branches. - * - * Note that by doing so, some mappings from var id to name - * in one context may be overriden by the ones in the other context. - * - * This should be ok because: - * - generally, the overriden variables should have been introduced *inside* - * the branches, in which case we don't care - * - or they were introduced before, in which case the naming should generally - * be consistent? In the worse case, it isn't, but it leads only to less - * readable code, not to unsoundness. This case should be pretty rare, - * also. - *) - let merge_ctxs (ctx0 : pn_ctx) (ctx1 : pn_ctx) : pn_ctx = - let pure_vars = - VarId.Map.fold - (fun id name ctx -> VarId.Map.add id name ctx) - ctx0.pure_vars ctx1.pure_vars - in - let llbc_vars = - V.VarId.Map.fold - (fun id name ctx -> V.VarId.Map.add id name ctx) - ctx0.llbc_vars ctx1.llbc_vars - in - { pure_vars; llbc_vars } - in - let empty_ctx = - { pure_vars = VarId.Map.empty; llbc_vars = V.VarId.Map.empty } - in - let merge_ctxs_ls (ctxs : pn_ctx list) : pn_ctx = - List.fold_left (fun ctx0 ctx1 -> merge_ctxs ctx0 ctx1) empty_ctx ctxs - in - - (* - * The way we do is as follows: - * - we explore the expressions - * - we register the variables introduced by the let-bindings - * - we use the naming information we find (through the variables and the - * meta-places) to update our context (i.e., maps from variable ids to - * names) - * - we use this information to update the names of the variables used in the - * expressions - *) - - (* Register a variable for constraints propagation - used when an variable is - * introduced (left-hand side of a left binding) *) - let register_var (ctx : pn_ctx) (v : var) : pn_ctx = - assert (not (VarId.Map.mem v.id ctx.pure_vars)); - match v.basename with - | None -> ctx - | Some name -> - let pure_vars = VarId.Map.add v.id name ctx.pure_vars in - { ctx with pure_vars } - in - (* Update a variable - used to update an expression after we computed constraints *) - let update_var (ctx : pn_ctx) (v : var) (mp : mplace option) : var = - match v.basename with - | Some _ -> v - | None -> ( - match VarId.Map.find_opt v.id ctx.pure_vars with - | Some basename -> { v with basename = Some basename } - | None -> - if Option.is_some mp then - match - V.VarId.Map.find_opt (Option.get mp).var_id ctx.llbc_vars - with - | None -> v - | Some basename -> { v with basename = Some basename } - else v) - in - (* Update an pattern - used to update an expression after we computed constraints *) - let update_typed_pattern ctx (lv : typed_pattern) : typed_pattern = - let obj = - object - inherit [_] map_typed_pattern - method! visit_PatVar _ v mp = PatVar (update_var ctx v mp, mp) - end - in - obj#visit_typed_pattern () lv - in - - (* Register an mplace the first time we find one *) - let register_mplace (mp : mplace) (ctx : pn_ctx) : pn_ctx = - match (V.VarId.Map.find_opt mp.var_id ctx.llbc_vars, mp.name) with - | None, Some name -> - let llbc_vars = V.VarId.Map.add mp.var_id name ctx.llbc_vars in - { ctx with llbc_vars } - | _ -> ctx - in - - (* Register the fact that [name] can be used for the pure variable identified - * by [var_id] (will add this name in the map if the variable is anonymous) *) - let add_pure_var_constraint (var_id : VarId.id) (name : string) (ctx : pn_ctx) - : pn_ctx = - let pure_vars = - if VarId.Map.mem var_id ctx.pure_vars then ctx.pure_vars - else VarId.Map.add var_id name ctx.pure_vars - in - { ctx with pure_vars } - in - (* Similar to [add_pure_var_constraint], but for LLBC variables *) - let add_llbc_var_constraint (var_id : V.VarId.id) (name : string) - (ctx : pn_ctx) : pn_ctx = - let llbc_vars = - if V.VarId.Map.mem var_id ctx.llbc_vars then ctx.llbc_vars - else V.VarId.Map.add var_id name ctx.llbc_vars - in - { ctx with llbc_vars } - in - (* Add a constraint: given a variable id and an associated meta-place, try to - * extract naming information from the meta-place and save it *) - let add_constraint (mp : mplace) (var_id : VarId.id) (ctx : pn_ctx) : pn_ctx = - (* Register the place *) - let ctx = register_mplace mp ctx in - (* Update the variable name *) - match (mp.name, mp.projection) with - | Some name, [] -> - (* Check if the variable already has a name - if not: insert the new name *) - let ctx = add_pure_var_constraint var_id name ctx in - let ctx = add_llbc_var_constraint mp.var_id name ctx in - ctx - | _ -> ctx - in - (* Specific case of constraint on rvalues *) - let add_right_constraint (mp : mplace) (rv : texpression) (ctx : pn_ctx) : - pn_ctx = - (* Register the place *) - let ctx = register_mplace mp ctx in - (* Add the constraint *) - match (unmeta rv).e with Var vid -> add_constraint mp vid ctx | _ -> ctx - in - (* Specific case of constraint on left values *) - let add_left_constraint (lv : typed_pattern) (ctx : pn_ctx) : pn_ctx = - let obj = - object (self) - inherit [_] reduce_typed_pattern - method zero _ = empty_ctx - method plus ctx0 ctx1 _ = merge_ctxs (ctx0 ()) (ctx1 ()) - - method! visit_PatVar _ v mp () = - (* Register the variable *) - let ctx = register_var (self#zero ()) v in - (* Register the mplace information if there is such information *) - match mp with Some mp -> add_constraint mp v.id ctx | None -> ctx - end - in - let ctx1 = obj#visit_typed_pattern () lv () in - merge_ctxs ctx ctx1 - in - - (* This is used to propagate constraint information about places in case of - * variable reassignments: we try to propagate the information from the - * rvalue to the left *) - let add_left_right_constraint (lv : typed_pattern) (re : texpression) - (ctx : pn_ctx) : pn_ctx = - (* We propagate constraints across variable reassignments: [^0 = x], - * if the destination doesn't have naming information *) - match lv.value with - | PatVar (({ id = _; basename = None; ty = _ } as lvar), lmp) -> - if - (* Check that there is not already a name for the variable *) - VarId.Map.mem lvar.id ctx.pure_vars - then ctx - else - (* We ignore the left meta-place information: it should have been taken - * care of by [add_left_constraint]. We try to use the right meta-place - * information *) - let add (name : string) (ctx : pn_ctx) : pn_ctx = - (* Add the constraint for the pure variable *) - let ctx = add_pure_var_constraint lvar.id name ctx in - (* Add the constraint for the LLBC variable *) - match lmp with - | None -> ctx - | Some lmp -> add_llbc_var_constraint lmp.var_id name ctx - in - (* We try to use the right-place information *) - let rmp, re = opt_unmeta_mplace re in - let ctx = - match rmp with - | Some { var_id; name; projection = [] } -> ( - if Option.is_some name then add (Option.get name) ctx - else - match V.VarId.Map.find_opt var_id ctx.llbc_vars with - | None -> ctx - | Some name -> add name ctx) - | _ -> ctx - in - (* We try to use the rvalue information, if it is a variable *) - let ctx = - match (unmeta re).e with - | Var rvar_id -> ( - match VarId.Map.find_opt rvar_id ctx.pure_vars with - | None -> ctx - | Some name -> add name ctx) - | _ -> ctx - in - ctx - | _ -> ctx - in - - (* *) - let rec update_texpression (e : texpression) (ctx : pn_ctx) : - pn_ctx * texpression = - let ty = e.ty in - let ctx, e = - match e.e with - | Var _ -> (* Nothing to do *) (ctx, e.e) - | Const _ -> (* Nothing to do *) (ctx, e.e) - | App (app, arg) -> - let ctx, app = update_texpression app ctx in - let ctx, arg = update_texpression arg ctx in - let e = App (app, arg) in - (ctx, e) - | Abs (x, e) -> update_abs x e ctx - | Qualif _ -> (* nothing to do *) (ctx, e.e) - | Let (monadic, lb, re, e) -> update_let monadic lb re e ctx - | Switch (scrut, body) -> update_switch_body scrut body ctx - | Meta (meta, e) -> update_meta meta e ctx - in - (ctx, { e; ty }) - (* *) - and update_abs (x : typed_pattern) (e : texpression) (ctx : pn_ctx) : - pn_ctx * expression = - (* We first add the left-constraint *) - let ctx = add_left_constraint x ctx in - (* Update the expression, and add additional constraints *) - let ctx, e = update_texpression e ctx in - (* Update the abstracted value *) - let x = update_typed_pattern ctx x in - (* Put together *) - (ctx, Abs (x, e)) - (* *) - and update_let (monadic : bool) (lv : typed_pattern) (re : texpression) - (e : texpression) (ctx : pn_ctx) : pn_ctx * expression = - (* We first add the left-constraint *) - let ctx = add_left_constraint lv ctx in - (* Then we try to propagate the right-constraints to the left, in case - * the left constraints didn't give naming information *) - let ctx = add_left_right_constraint lv re ctx in - let ctx, re = update_texpression re ctx in - let ctx, e = update_texpression e ctx in - let lv = update_typed_pattern ctx lv in - (ctx, Let (monadic, lv, re, e)) - (* *) - and update_switch_body (scrut : texpression) (body : switch_body) - (ctx : pn_ctx) : pn_ctx * expression = - let ctx, scrut = update_texpression scrut ctx in - - let ctx, body = - match body with - | If (e_true, e_false) -> - let ctx1, e_true = update_texpression e_true ctx in - let ctx2, e_false = update_texpression e_false ctx in - let ctx = merge_ctxs ctx1 ctx2 in - (ctx, If (e_true, e_false)) - | Match branches -> - let ctx_branches_ls = - List.map - (fun br -> - let ctx = add_left_constraint br.pat ctx in - let ctx, branch = update_texpression br.branch ctx in - let pat = update_typed_pattern ctx br.pat in - (ctx, { pat; branch })) - branches - in - let ctxs, branches = List.split ctx_branches_ls in - let ctx = merge_ctxs_ls ctxs in - (ctx, Match branches) - in - (ctx, Switch (scrut, body)) - (* *) - and update_meta (meta : meta) (e : texpression) (ctx : pn_ctx) : - pn_ctx * expression = - let ctx = - match meta with - | Assignment (mp, rvalue, rmp) -> - let ctx = add_right_constraint mp rvalue ctx in - let ctx = - match (mp.projection, rmp) with - | [], Some { var_id; name; projection = [] } -> ( - let name = - match name with - | Some name -> Some name - | None -> V.VarId.Map.find_opt var_id ctx.llbc_vars - in - match name with - | None -> ctx - | Some name -> add_llbc_var_constraint mp.var_id name ctx) - | _ -> ctx - in - ctx - | MPlace mp -> add_right_constraint mp e ctx - in - let ctx, e = update_texpression e ctx in - let e = mk_meta meta e in - (ctx, e.e) - in - - let body = - match def.body with - | None -> None - | Some body -> - let input_names = - List.filter_map - (fun (v : var) -> - match v.basename with - | None -> None - | Some name -> Some (v.id, name)) - body.inputs - in - let ctx = - { - pure_vars = VarId.Map.of_list input_names; - llbc_vars = V.VarId.Map.empty; - } - in - let _, body_exp = update_texpression body.body ctx in - Some { body with body = body_exp } - in - { def with body } - -(** Remove the meta-information *) -let remove_meta (def : fun_decl) : fun_decl = - match def.body with - | None -> def - | Some body -> - let body = { body with body = PureUtils.remove_meta body.body } in - { def with body = Some body } - -(** Inline the useless variable (re-)assignments: - - A lot of intermediate variable assignments are introduced through the - compilation to MIR and by the translation itself (and the variable used - on the left is often unnamed). - - Note that many of them are just variable "reassignments": [let x = y in ...]. - Some others come from ?? - - TODO: how do we call that when we introduce intermediate variable assignments - for the arguments of a function call? - - [inline_named]: if [true], inline all the assignments of the form - [let VAR = VAR in ...], otherwise inline only the ones where the variable - on the left is anonymous. - - [inline_pure]: if [true], inline all the pure assignments where the variable - on the left is anonymous, but the assignments where the r-expression is - a non-primitive function call (i.e.: inline the binops, ADT constructions, - etc.). - - TODO: we have a smallish issue which is that rvalues should be merged with - expressions... For now, this forces us to substitute whenever we can, but - leave the let-bindings where they are, and eliminated them in a subsequent - pass (if they are useless). - *) -let inline_useless_var_reassignments (inline_named : bool) (inline_pure : bool) - (def : fun_decl) : fun_decl = - let obj = - object (self) - inherit [_] map_expression as super - - (** Visit the let-bindings to filter the useless ones (and update - the substitution map while doing so *) - method! visit_Let (env : texpression VarId.Map.t) monadic lv re e = - (* In order to filter, we need to check first that: - * - the let-binding is not monadic - * - the left-value is a variable - *) - match (monadic, lv.value) with - | false, PatVar (lv_var, _) -> - (* We can filter if: *) - (* 1. the left variable is unnamed or [inline_named] is true *) - let filter_left = - match (inline_named, lv_var.basename) with - | true, _ | _, None -> true - | _ -> false - in - (* And either: - * 2.1 the right-expression is a variable or a global *) - let var_or_global = is_var re || is_global re in - (* Or: - * 2.2 the right-expression is a constant value, an ADT value, - * a projection or a primitive function call *and* the flag - * [inline_pure] is set *) - let pure_re = - is_const re - || - let app, _ = destruct_apps re in - match app.e with - | Qualif qualif -> ( - match qualif.id with - | AdtCons _ -> true (* ADT constructor *) - | Proj _ -> true (* Projector *) - | Func (Unop _ | Binop _) -> - true (* primitive function call *) - | Func (Regular _) -> false (* non-primitive function call *) - | _ -> false) - | _ -> false - in - let filter = - filter_left && (var_or_global || (inline_pure && pure_re)) - in - - (* Update the rhs (we may perform substitutions inside, and it is - * better to do them *before* we inline it *) - let re = self#visit_texpression env re in - (* Update the substitution environment *) - let env = if filter then VarId.Map.add lv_var.id re env else env in - (* Update the next expression *) - let e = self#visit_texpression env e in - (* Reconstruct the [let], only if the binding is not filtered *) - if filter then e.e else Let (monadic, lv, re, e) - | _ -> super#visit_Let env monadic lv re e - - (** Substitute the variables *) - method! visit_Var (env : texpression VarId.Map.t) (vid : VarId.id) = - match VarId.Map.find_opt vid env with - | None -> (* No substitution *) super#visit_Var env vid - | Some ne -> - (* Substitute - note that we need to reexplore, because - * there may be stacked substitutions, if we have: - * var0 --> var1 - * var1 --> var2. - *) - self#visit_expression env ne.e - end - in - match def.body with - | None -> def - | Some body -> - let body = - { body with body = obj#visit_texpression VarId.Map.empty body.body } - in - { def with body = Some body } - -(** Given a forward or backward function call, is there, for every execution - path, a child backward function called later with exactly the same input - list prefix? We use this to filter useless function calls: if there are - such child calls, we can remove this one (in case its outputs are not - used). - We do this check because we can't simply remove function calls whose - outputs are not used, as they might fail. However, if a function fails, - its children backward functions then fail on the same inputs (ignoring - the additional inputs those receive). - - For instance, if we have: - {[ - fn f<'a>(x : &'a mut T); - ]} - - We often have things like this in the synthesized code: - {[ - _ <-- f x; - ... - nx <-- f@back'a x y; - ... - ]} - - In this situation, we can remove the call [f x]. - *) -let expression_contains_child_call_in_all_paths (ctx : trans_ctx) - (fun_id0 : fun_id) (tys0 : ty list) (args0 : texpression list) - (e : texpression) : bool = - let check_call (fun_id1 : fun_id) (tys1 : ty list) (args1 : texpression list) - : bool = - (* Check the fun_ids, to see if call1's function is a child of call0's function *) - match (fun_id0, fun_id1) with - | Regular (id0, rg_id0), Regular (id1, rg_id1) -> - (* Both are "regular" calls: check if they come from the same rust function *) - if id0 = id1 then - (* Same rust functions: check the regions hierarchy *) - let call1_is_child = - match (rg_id0, rg_id1) with - | None, _ -> - (* The function used in call0 is the forward function: the one - * used in call1 is necessarily a child *) - true - | Some _, None -> - (* Opposite of previous case *) - false - | Some rg_id0, Some rg_id1 -> - if rg_id0 = rg_id1 then true - else - (* We need to use the regions hierarchy *) - (* First, lookup the signature of the LLBC function *) - let sg = - LlbcAstUtils.lookup_fun_sig id0 ctx.fun_context.fun_decls - in - (* Compute the set of ancestors of the function in call1 *) - let call1_ancestors = - LlbcAstUtils.list_parent_region_groups sg rg_id1 - in - (* Check if the function used in call0 is inside *) - T.RegionGroupId.Set.mem rg_id0 call1_ancestors - in - (* If call1 is a child, then we need to check if the input arguments - * used in call0 are a prefix of the input arguments used in call1 - * (note call1 being a child, it will likely consume strictly more - * given back values). - * *) - if call1_is_child then - let call1_args = - Collections.List.prefix (List.length args0) args1 - in - let args = List.combine args0 call1_args in - (* Note that the input values are expressions, *which may contain - * meta-values* (which we need to ignore). *) - let input_eq (v0, v1) = - PureUtils.remove_meta v0 = PureUtils.remove_meta v1 - in - (* Compare the input types and the prefix of the input arguments *) - tys0 = tys1 && List.for_all input_eq args - else (* Not a child *) - false - else (* Not the same function *) - false - | _ -> false - in - - let visitor = - object (self) - inherit [_] reduce_expression - method zero _ = false - method plus b0 b1 _ = b0 () && b1 () - - method! visit_texpression env e = - match e.e with - | Var _ | Const _ -> fun _ -> false - | Let (_, _, re, e) -> ( - match opt_destruct_function_call re with - | None -> fun () -> self#visit_texpression env e () - | Some (func1, tys1, args1) -> - let call_is_child = check_call func1 tys1 args1 in - if call_is_child then fun () -> true - else fun () -> self#visit_texpression env e ()) - | App _ -> ( - fun () -> - match opt_destruct_function_call e with - | Some (func1, tys1, args1) -> check_call func1 tys1 args1 - | None -> false) - | Abs (_, e) -> self#visit_texpression env e - | Qualif _ -> - (* Note that this case includes functions without arguments *) - fun () -> false - | Meta (_, e) -> self#visit_texpression env e - | Switch (_, body) -> self#visit_switch_body env body - - method! visit_switch_body env body = - match body with - | If (e1, e2) -> - fun () -> - self#visit_texpression env e1 () - && self#visit_texpression env e2 () - | Match branches -> - fun () -> - List.for_all - (fun br -> self#visit_texpression env br.branch ()) - branches - end - in - visitor#visit_texpression () e () - -(** Filter the useless assignments (removes the useless variables, filters - the function calls) *) -let filter_useless (filter_monadic_calls : bool) (ctx : trans_ctx) - (def : fun_decl) : fun_decl = - (* We first need a transformation on *left-values*, which filters the useless - * variables and tells us whether the value contains any variable which has - * not been replaced by [_] (in which case we need to keep the assignment, - * etc.). - * - * This is implemented as a map-reduce. - * - * Returns: ( filtered_left_value, *all_dummies* ) - * - * [all_dummies]: - * If the returned boolean is true, it means that all the variables appearing - * in the filtered left-value are *dummies* (meaning that if this left-value - * appears at the left of a let-binding, this binding might potentially be - * removed). - *) - let lv_visitor = - object - inherit [_] mapreduce_typed_pattern - method zero _ = true - method plus b0 b1 _ = b0 () && b1 () - - method! visit_PatVar env v mp = - if VarId.Set.mem v.id env then (PatVar (v, mp), fun _ -> false) - else (PatDummy, fun _ -> true) - end - in - let filter_typed_pattern (used_vars : VarId.Set.t) (lv : typed_pattern) : - typed_pattern * bool = - let lv, all_dummies = lv_visitor#visit_typed_pattern used_vars lv in - (lv, all_dummies ()) - in - - (* We then implement the transformation on *expressions* through a mapreduce. - * Note that the transformation is bottom-up. - * The map filters the useless assignments, the reduce computes the set of - * used variables. - *) - let expr_visitor = - object (self) - inherit [_] mapreduce_expression as super - method zero _ = VarId.Set.empty - method plus s0 s1 _ = VarId.Set.union (s0 ()) (s1 ()) - - (** Whenever we visit a variable, we need to register the used variable *) - method! visit_Var _ vid = (Var vid, fun _ -> VarId.Set.singleton vid) - - method! visit_expression env e = - match e with - | Var _ | Const _ | App _ | Qualif _ - | Switch (_, _) - | Meta (_, _) - | Abs _ -> - super#visit_expression env e - | Let (monadic, lv, re, e) -> - (* Compute the set of values used in the next expression *) - let e, used = self#visit_texpression env e in - let used = used () in - (* Filter the left values *) - let lv, all_dummies = filter_typed_pattern used lv in - (* Small utility - called if we can't filter the let-binding *) - let dont_filter () = - let re, used_re = self#visit_texpression env re in - let used = VarId.Set.union used (used_re ()) in - (Let (monadic, lv, re, e), fun _ -> used) - in - (* Potentially filter the let-binding *) - if all_dummies then - if not monadic then - (* Not a monadic let-binding: simple case *) - (e.e, fun _ -> used) - else - (* Monadic let-binding: trickier. - * We can filter if the right-expression is a function call, - * under some conditions. *) - match (filter_monadic_calls, opt_destruct_function_call re) with - | true, Some (func, tys, args) -> - (* We need to check if there is a child call - see - * the comments for: - * [expression_contains_child_call_in_all_paths] *) - let has_child_call = - expression_contains_child_call_in_all_paths ctx func tys - args e - in - if has_child_call then (* Filter *) - (e.e, fun _ -> used) - else (* No child call: don't filter *) - dont_filter () - | _ -> - (* Not a call or not allowed to filter: we can't filter *) - dont_filter () - else (* There are used variables: don't filter *) - dont_filter () - end - in - (* We filter only inside of transparent (i.e., non-opaque) definitions *) - match def.body with - | None -> def - | Some body -> - (* Visit the body *) - let body_exp, used_vars = expr_visitor#visit_texpression () body.body in - (* Visit the parameters - TODO: update: we can filter only if the definition - * is not recursive (otherwise it might mess up with the decrease clauses: - * the decrease clauses uses all the inputs given to the function, if some - * inputs are replaced by '_' we can't give it to the function used in the - * decreases clause). - * For now we deactivate the filtering. *) - let used_vars = used_vars () in - let inputs_lvs = - if false then - List.map - (fun lv -> fst (filter_typed_pattern used_vars lv)) - body.inputs_lvs - else body.inputs_lvs - in - (* Return *) - let body = { body with body = body_exp; inputs_lvs } in - { def with body = Some body } - -(** Simplify the aggregated ADTs. - Ex.: - {[ - type struct = { f0 : nat; f1 : nat } - - Mkstruct x.f0 x.f1 ~~> x - ]} - - TODO: introduce a notation for [{ x with field = ... }], and use it. - *) -let simplify_aggregates (ctx : trans_ctx) (def : fun_decl) : fun_decl = - let expr_visitor = - object - inherit [_] map_expression as super - - (* Look for a type constructor applied to arguments *) - method! visit_texpression env e = - match e.e with - | App _ -> ( - let app, args = destruct_apps e in - match app.e with - | Qualif - { - id = AdtCons { adt_id = AdtId adt_id; variant_id = None }; - type_args; - } -> - (* This is a struct *) - (* Retrieve the definiton, to find how many fields there are *) - let adt_decl = - TypeDeclId.Map.find adt_id ctx.type_context.type_decls - in - let fields = - match adt_decl.kind with - | Enum _ | Opaque -> raise (Failure "Unreachable") - | Struct fields -> fields - in - let num_fields = List.length fields in - (* In order to simplify, there must be as many arguments as - * there are fields *) - assert (num_fields > 0); - if num_fields = List.length args then - (* We now need to check that all the arguments are of the form: - * [x.field] for some variable [x], and where the projection - * is for the proper ADT *) - let to_var_proj (i : int) (arg : texpression) : - (ty list * var_id) option = - match arg.e with - | App (proj, x) -> ( - match (proj.e, x.e) with - | ( Qualif - { - id = - Proj { adt_id = AdtId proj_adt_id; field_id }; - type_args = proj_type_args; - }, - Var v ) -> - (* We check that this is the proper ADT, and the proper field *) - if - proj_adt_id = adt_id - && FieldId.to_int field_id = i - then Some (proj_type_args, v) - else None - | _ -> None) - | _ -> None - in - let args = List.mapi to_var_proj args in - let args = List.filter_map (fun x -> x) args in - (* Check that all the arguments are of the expected form *) - if List.length args = num_fields then - (* Check that this is the same variable we project from - - * note that we checked above that there is at least one field *) - let (_, x), end_args = Collections.List.pop args in - if List.for_all (fun (_, y) -> y = x) end_args then ( - (* We can substitute *) - (* Sanity check: all types correct *) - assert ( - List.for_all (fun (tys, _) -> tys = type_args) args); - { e with e = Var x }) - else super#visit_texpression env e - else super#visit_texpression env e - else super#visit_texpression env e - | _ -> super#visit_texpression env e) - | _ -> super#visit_texpression env e - end - in - match def.body with - | None -> def - | Some body -> - (* Visit the body *) - let body_exp = expr_visitor#visit_texpression () body.body in - (* Return *) - let body = { body with body = body_exp } in - { def with body = Some body } - -(** Return [None] if the function is a backward function with no outputs (so - that we eliminate the definition which is useless). - - Note that the calls to such functions are filtered when translating from - symbolic to pure. Here, we remove the definitions altogether, because they - are now useless - *) -let filter_if_backward_with_no_outputs (config : config) (def : fun_decl) : - fun_decl option = - if - config.filter_useless_functions && Option.is_some def.back_id - && def.signature.output = mk_result_ty mk_unit_ty - then None - else Some def - -(** Return [false] if the forward function is useless and should be filtered. - - - a forward function with no output (comes from a Rust function with - unit return type) - - the function has mutable borrows as inputs (which is materialized - by the fact we generated backward functions which were not filtered). - - In such situation, every call to the Rust function will be translated to: - - a call to the forward function which returns nothing - - calls to the backward functions - As a failing backward function implies the forward function also fails, - we can filter the calls to the forward function, which thus becomes - useless. - In such situation, we can remove the forward function definition - altogether. - *) -let keep_forward (config : config) (trans : pure_fun_translation) : bool = - let fwd, backs = trans in - (* Note that at this point, the output types are no longer seen as tuples: - * they should be lists of length 1. *) - if - config.filter_useless_functions - && fwd.signature.output = mk_result_ty mk_unit_ty - && backs <> [] - then false - else true - -(** Convert the unit variables to [()] if they are used as right-values or - [_] if they are used as left values in patterns. *) -let unit_vars_to_unit (def : fun_decl) : fun_decl = - (* The map visitor *) - let obj = - object - inherit [_] map_expression as super - - (** Replace in patterns *) - method! visit_PatVar _ v mp = - if v.ty = mk_unit_ty then PatDummy else PatVar (v, mp) - - (** Replace in "regular" expressions - note that we could limit ourselves - to variables, but this is more powerful - *) - method! visit_texpression env e = - if e.ty = mk_unit_ty then mk_unit_rvalue - else super#visit_texpression env e - end - in - (* Update the body *) - match def.body with - | None -> def - | Some body -> - let body_exp = obj#visit_texpression () body.body in - (* Update the input parameters *) - let inputs_lvs = List.map (obj#visit_typed_pattern ()) body.inputs_lvs in - (* Return *) - let body = Some { body with body = body_exp; inputs_lvs } in - { def with body } - -(** Eliminate the box functions like [Box::new], [Box::deref], etc. Most of them - are translated to identity, and [Box::free] is translated to [()]. - - Note that the box types have already been eliminated during the translation - from symbolic to pure. - The reason why we don't eliminate the box functions at the same time is - that we would need to eliminate them in two different places: when translating - function calls, and when translating end abstractions. Here, we can do - something simpler, in one micro-pass. - *) -let eliminate_box_functions (_ctx : trans_ctx) (def : fun_decl) : fun_decl = - (* The map visitor *) - let obj = - object - inherit [_] map_expression as super - - method! visit_texpression env e = - match opt_destruct_function_call e with - | Some (fun_id, _tys, args) -> ( - match fun_id with - | Regular (A.Assumed aid, rg_id) -> ( - (* Below, when dealing with the arguments: we consider the very - * general case, where functions could be boxed (meaning we - * could have: [box_new f x]) - * *) - match (aid, rg_id) with - | A.BoxNew, _ -> - assert (rg_id = None); - let arg, args = Collections.List.pop args in - mk_apps arg args - | A.BoxDeref, None -> - (* [Box::deref] forward is the identity *) - let arg, args = Collections.List.pop args in - mk_apps arg args - | A.BoxDeref, Some _ -> - (* [Box::deref] backward is [()] (doesn't give back anything) *) - assert (args = []); - mk_unit_rvalue - | A.BoxDerefMut, None -> - (* [Box::deref_mut] forward is the identity *) - let arg, args = Collections.List.pop args in - mk_apps arg args - | A.BoxDerefMut, Some _ -> - (* [Box::deref_mut] back is almost the identity: - * let box_deref_mut (x_init : t) (x_back : t) : t = x_back - * *) - let arg, args = - match args with - | _ :: given_back :: args -> (given_back, args) - | _ -> failwith "Unreachable" - in - mk_apps arg args - | A.BoxFree, _ -> - assert (args = []); - mk_unit_rvalue - | ( ( A.Replace | A.VecNew | A.VecPush | A.VecInsert | A.VecLen - | A.VecIndex | A.VecIndexMut ), - _ ) -> - super#visit_texpression env e) - | _ -> super#visit_texpression env e) - | _ -> super#visit_texpression env e - end - in - (* Update the body *) - match def.body with - | None -> def - | Some body -> - let body = Some { body with body = obj#visit_texpression () body.body } in - { def with body } - -(** Decompose the monadic let-bindings. - - See the explanations in [config]. - *) -let decompose_monadic_let_bindings (_ctx : trans_ctx) (def : fun_decl) : - fun_decl = - match def.body with - | None -> def - | Some body -> - (* Set up the var id generator *) - let cnt = get_body_min_var_counter body in - let _, fresh_id = VarId.mk_stateful_generator cnt in - (* It is a very simple map *) - let obj = - object (self) - inherit [_] map_expression as super - - method! visit_Let env monadic lv re next_e = - if not monadic then super#visit_Let env monadic lv re next_e - else - (* If monadic, we need to check if the left-value is a variable: - * - if yes, don't decompose - * - if not, make the decomposition in two steps - *) - match lv.value with - | PatVar _ -> - (* Variable: nothing to do *) - super#visit_Let env monadic lv re next_e - | _ -> - (* Not a variable: decompose *) - (* Introduce a temporary variable to receive the value of the - * monadic binding *) - let vid = fresh_id () in - let tmp : var = { id = vid; basename = None; ty = lv.ty } in - let ltmp = mk_typed_pattern_from_var tmp None in - let rtmp = mk_texpression_from_var tmp in - (* Visit the next expression *) - let next_e = self#visit_texpression env next_e in - (* Create the let-bindings *) - (mk_let true ltmp re (mk_let false lv rtmp next_e)).e - end - in - (* Update the body *) - let body = Some { body with body = obj#visit_texpression () body.body } in - (* Return *) - { def with body } - -(** Unfold the monadic let-bindings to explicit matches. *) -let unfold_monadic_let_bindings (_ctx : trans_ctx) (def : fun_decl) : fun_decl = - match def.body with - | None -> def - | Some body -> - (* It is a very simple map *) - let obj = - object (_self) - inherit [_] map_expression as super - - method! visit_Let env monadic lv re e = - (* We simply do the following transformation: - {[ - pat <-- re; e - - ~~> - - match re with - | Fail err -> Fail err - | Return pat -> e - ]} - *) - (* TODO: we should use a monad "kind" instead of a boolean *) - if not monadic then super#visit_Let env monadic lv re e - else - (* We don't do the same thing if we use a state-error monad or simply - an error monad. - Note that some functions always live in the error monad (arithmetic - operations, for instance). - *) - (* TODO: this information should be computed in SymbolicToPure and - * store in an enum ("monadic" should be an enum, not a bool). *) - let re_ty = Option.get (opt_destruct_result re.ty) in - assert (lv.ty = re_ty); - let fail_pat = mk_result_fail_pattern lv.ty in - let fail_value = mk_result_fail_texpression e.ty in - let fail_branch = { pat = fail_pat; branch = fail_value } in - let success_pat = mk_result_return_pattern lv in - let success_branch = { pat = success_pat; branch = e } in - let switch_body = Match [ fail_branch; success_branch ] in - let e = Switch (re, switch_body) in - (* Continue *) - super#visit_expression env e - end - in - (* Update the body *) - let body_e = obj#visit_texpression () body.body in - let body = { body with body = body_e } in - (* Return *) - { def with body = Some body } - -(** Apply all the micro-passes to a function. - - Will return [None] if the function is a backward function with no outputs. - - [ctx]: used only for printing. - *) -let apply_passes_to_def (config : config) (ctx : trans_ctx) (def : fun_decl) : - fun_decl option = - (* Debug *) - log#ldebug - (lazy - ("PureMicroPasses.apply_passes_to_def: " - ^ Print.fun_name_to_string def.basename - ^ " (" - ^ Print.option_to_string T.RegionGroupId.to_string def.back_id - ^ ")")); - - (* First, find names for the variables which are unnamed *) - let def = compute_pretty_names def in - log#ldebug - (lazy ("compute_pretty_name:\n\n" ^ fun_decl_to_string ctx def ^ "\n")); - - (* TODO: we might want to leverage more the assignment meta-data, for - * aggregates for instance. *) - - (* TODO: reorder the branches of the matches/switches *) - - (* The meta-information is now useless: remove it. - * Rk.: some passes below use the fact that we removed the meta-data - * (otherwise we would have to "unmeta" expressions before matching) *) - let def = remove_meta def in - log#ldebug (lazy ("remove_meta:\n\n" ^ fun_decl_to_string ctx def ^ "\n")); - - (* Remove the backward functions with no outputs. - * Note that the calls to those functions should already have been removed, - * when translating from symbolic to pure. Here, we remove the definitions - * altogether, because they are now useless *) - let def = filter_if_backward_with_no_outputs config def in - - match def with - | None -> None - | Some def -> - (* Convert the unit variables to [()] if they are used as right-values or - * [_] if they are used as left values. *) - let def = unit_vars_to_unit def in - log#ldebug - (lazy ("unit_vars_to_unit:\n\n" ^ fun_decl_to_string ctx def ^ "\n")); - - (* Inline the useless variable reassignments *) - let inline_named_vars = true in - let inline_pure = true in - let def = - inline_useless_var_reassignments inline_named_vars inline_pure def - in - log#ldebug - (lazy - ("inline_useless_var_assignments:\n\n" ^ fun_decl_to_string ctx def - ^ "\n")); - - (* Eliminate the box functions - note that the "box" types were eliminated - * during the symbolic to pure phase: see the comments for [eliminate_box_functions] *) - let def = eliminate_box_functions ctx def in - log#ldebug - (lazy - ("eliminate_box_functions:\n\n" ^ fun_decl_to_string ctx def ^ "\n")); - - (* Filter the useless variables, assignments, function calls, etc. *) - let def = filter_useless config.filter_useless_monadic_calls ctx def in - log#ldebug - (lazy ("filter_useless:\n\n" ^ fun_decl_to_string ctx def ^ "\n")); - - (* Simplify the aggregated ADTs. - Ex.: - {[ - type struct = { f0 : nat; f1 : nat } - - Mkstruct x.f0 x.f1 ~~> x - ]} - *) - let def = simplify_aggregates ctx def in - log#ldebug - (lazy ("simplify_aggregates:\n\n" ^ fun_decl_to_string ctx def ^ "\n")); - - (* Decompose the monadic let-bindings - F* specific - * TODO: remove? *) - let def = - if config.decompose_monadic_let_bindings then ( - let def = decompose_monadic_let_bindings ctx def in - log#ldebug - (lazy - ("decompose_monadic_let_bindings:\n\n" - ^ fun_decl_to_string ctx def ^ "\n")); - def) - else ( - log#ldebug - (lazy - "ignoring decompose_monadic_let_bindings due to the configuration\n"); - def) - in - - (* Unfold the monadic let-bindings *) - let def = - if config.unfold_monadic_let_bindings then ( - let def = unfold_monadic_let_bindings ctx def in - log#ldebug - (lazy - ("unfold_monadic_let_bindings:\n\n" ^ fun_decl_to_string ctx def - ^ "\n")); - def) - else ( - log#ldebug - (lazy - "ignoring unfold_monadic_let_bindings due to the configuration\n"); - def) - in - - (* We are done *) - Some def - -(** Return the forward/backward translations on which we applied the micro-passes. - - Also returns a boolean indicating whether the forward function should be kept - or not (because useful/useless - [true] means we need to keep the forward - function). - Note that we don't "filter" the forward function and return a boolean instead, - because this function contains useful information to extract the backward - functions: keeping it is not necessary but more convenient. - *) -let apply_passes_to_pure_fun_translation (config : config) (ctx : trans_ctx) - (trans : pure_fun_translation) : bool * pure_fun_translation = - (* Apply the passes to the individual functions *) - let forward, backwards = trans in - let forward = Option.get (apply_passes_to_def config ctx forward) in - let backwards = List.filter_map (apply_passes_to_def config ctx) backwards in - let trans = (forward, backwards) in - (* Compute whether we need to filter the forward function or not *) - (keep_forward config trans, trans) diff --git a/src/PureToExtract.ml b/src/PureToExtract.ml deleted file mode 100644 index 77c3afd4..00000000 --- a/src/PureToExtract.ml +++ /dev/null @@ -1,723 +0,0 @@ -(** This module is used to extract the pure ASTs to various theorem provers. - It defines utilities and helpers to make the work as easy as possible: - we try to factorize as much as possible the different extractions to the - backends we target. - *) - -open Pure -open TranslateCore -module C = Contexts -module RegionVarId = T.RegionVarId -module F = Format - -(** The local logger *) -let log = L.pure_to_extract_log - -type region_group_info = { - id : RegionGroupId.id; - (** The id of the region group. - Note that a simple way of generating unique names for backward - functions is to use the region group ids. - *) - region_names : string option list; - (** The names of the region variables included in this group. - Note that names are not always available... - *) -} - -module StringSet = Collections.MakeSet (Collections.OrderedString) -module StringMap = Collections.MakeMap (Collections.OrderedString) - -type name = Names.name -type type_name = Names.type_name -type global_name = Names.global_name -type fun_name = Names.fun_name - -(* TODO: this should a module we give to a functor! *) - -(** A formatter's role is twofold: - 1. Come up with name suggestions. - For instance, provided some information about a function (its basename, - information about the region group, etc.) it should come up with an - appropriate name for the forward/backward function. - - It can of course apply many transformations, like changing to camel case/ - snake case, adding prefixes/suffixes, etc. - - 2. Format some specific terms, like constants. - *) -type formatter = { - bool_name : string; - char_name : string; - int_name : integer_type -> string; - str_name : string; - field_name : name -> FieldId.id -> string option -> string; - (** Inputs: - - type name - - field id - - field name - - Note that fields don't always have names, but we still need to - generate some names if we want to extract the structures to records... - We might want to extract such structures to tuples, later, but field - access then causes trouble because not all provers accept syntax like - [x.3] where [x] is a tuple. - *) - variant_name : name -> string -> string; - (** Inputs: - - type name - - variant name - *) - struct_constructor : name -> string; - (** Structure constructors are used when constructing structure values. - - For instance, in F*: - {[ - type pair = { x : nat; y : nat } - let p : pair = Mkpair 0 1 - ]} - - Inputs: - - type name - *) - type_name : type_name -> string; - (** Provided a basename, compute a type name. *) - global_name : global_name -> string; - (** Provided a basename, compute a global name. *) - fun_name : - A.fun_id -> - fun_name -> - int -> - region_group_info option -> - bool * int -> - string; - (** Inputs: - - function id: this is especially useful to identify whether the - function is an assumed function or a local function - - function basename - - number of region groups - - region group information in case of a backward function - ([None] if forward function) - - pair: - - do we generate the forward function (it may have been filtered)? - - the number of extracted backward functions (not necessarily equal - to the number of region groups, because we may have filtered - some of them) - TODO: use the fun id for the assumed functions. - *) - decreases_clause_name : A.FunDeclId.id -> fun_name -> string; - (** Generates the name of the definition used to prove/reason about - termination. The generated code uses this clause where needed, - but its body must be defined by the user. - - Inputs: - - function id: this is especially useful to identify whether the - function is an assumed function or a local function - - function basename - *) - var_basename : StringSet.t -> string option -> ty -> string; - (** Generates a variable basename. - - Inputs: - - the set of names used in the context so far - - the basename we got from the symbolic execution, if we have one - - the type of the variable (can be useful for heuristics, in order - not to always use "x" for instance, whenever naming anonymous - variables) - - Note that once the formatter generated a basename, we add an index - if necessary to prevent name clashes: the burden of name clashes checks - is thus on the caller's side. - *) - type_var_basename : StringSet.t -> string -> string; - (** Generates a type variable basename. *) - append_index : string -> int -> string; - (** Appends an index to a name - we use this to generate unique - names: when doing so, the role of the formatter is just to concatenate - indices to names, the responsability of finding a proper index is - delegated to helper functions. - *) - extract_constant_value : F.formatter -> bool -> constant_value -> unit; - (** Format a constant value. - - Inputs: - - formatter - - [inside]: if [true], the value should be wrapped in parentheses - if it is made of an application (ex.: [U32 3]) - - the constant value - *) - extract_unop : - (bool -> texpression -> unit) -> - F.formatter -> - bool -> - unop -> - texpression -> - unit; - (** Format a unary operation - - Inputs: - - a formatter for expressions (called on the argument of the unop) - - extraction context (see below) - - formatter - - expression formatter - - [inside] - - unop - - argument - *) - extract_binop : - (bool -> texpression -> unit) -> - F.formatter -> - bool -> - E.binop -> - integer_type -> - texpression -> - texpression -> - unit; - (** Format a binary operation - - Inputs: - - a formatter for expressions (called on the arguments of the binop) - - extraction context (see below) - - formatter - - expression formatter - - [inside] - - binop - - argument 0 - - argument 1 - *) -} - -(** We use identifiers to look for name clashes *) -type id = - | GlobalId of A.GlobalDeclId.id - | FunId of A.fun_id * RegionGroupId.id option - | DecreasesClauseId of A.fun_id - (** The definition which provides the decreases/termination clause. - We insert calls to this clause to prove/reason about termination: - the body of those clauses must be defined by the user, in the - proper files. - *) - | TypeId of type_id - | StructId of type_id - (** We use this when we manipulate the names of the structure - constructors. - - For instance, in F*: - {[ - type pair = { x: nat; y : nat } - let p : pair = Mkpair 0 1 - ]} - *) - | VariantId of type_id * VariantId.id - (** If often happens that variant names must be unique (it is the case in - F* ) which is why we register them here. - *) - | FieldId of type_id * FieldId.id - (** If often happens that in the case of structures, the field names - must be unique (it is the case in F* ) which is why we register - them here. - *) - | TypeVarId of TypeVarId.id - | VarId of VarId.id - | UnknownId - (** Used for stored various strings like keywords, definitions which - should always be in context, etc. and which can't be linked to one - of the above. - *) -[@@deriving show, ord] - -module IdOrderedType = struct - type t = id - - let compare = compare_id - let to_string = show_id - let pp_t = pp_id - let show_t = show_id -end - -module IdMap = Collections.MakeMap (IdOrderedType) - -(** The names map stores the mappings from names to identifiers and vice-versa. - - We use it for lookups (during the translation) and to check for name clashes. - - [id_to_string] is for debugging. - *) -type names_map = { - id_to_name : string IdMap.t; - name_to_id : id StringMap.t; - (** The name to id map is used to look for name clashes, and generate nice - debugging messages: if there is a name clash, it is useful to know - precisely which identifiers are mapped to the same name... - *) - names_set : StringSet.t; -} - -let names_map_add (id_to_string : id -> string) (id : id) (name : string) - (nm : names_map) : names_map = - (* Check if there is a clash *) - (match StringMap.find_opt name nm.name_to_id with - | None -> () (* Ok *) - | Some clash -> - (* There is a clash: print a nice debugging message for the user *) - let id1 = "\n- " ^ id_to_string clash in - let id2 = "\n- " ^ id_to_string id in - let err = - "Name clash detected: the following identifiers are bound to the same \ - name \"" ^ name ^ "\":" ^ id1 ^ id2 - in - log#serror err; - failwith err); - (* Sanity check *) - assert (not (StringSet.mem name nm.names_set)); - (* Insert *) - let id_to_name = IdMap.add id name nm.id_to_name in - let name_to_id = StringMap.add name id nm.name_to_id in - let names_set = StringSet.add name nm.names_set in - { id_to_name; name_to_id; names_set } - -let names_map_add_assumed_type (id_to_string : id -> string) (id : assumed_ty) - (name : string) (nm : names_map) : names_map = - names_map_add id_to_string (TypeId (Assumed id)) name nm - -let names_map_add_assumed_struct (id_to_string : id -> string) (id : assumed_ty) - (name : string) (nm : names_map) : names_map = - names_map_add id_to_string (StructId (Assumed id)) name nm - -let names_map_add_assumed_variant (id_to_string : id -> string) - (id : assumed_ty) (variant_id : VariantId.id) (name : string) - (nm : names_map) : names_map = - names_map_add id_to_string (VariantId (Assumed id, variant_id)) name nm - -let names_map_add_assumed_function (id_to_string : id -> string) - (fid : A.assumed_fun_id) (rg_id : RegionGroupId.id option) (name : string) - (nm : names_map) : names_map = - names_map_add id_to_string (FunId (A.Assumed fid, rg_id)) name nm - -(** Make a (variable) basename unique (by adding an index). - - We do this in an inefficient manner (by testing all indices starting from - 0) but it shouldn't be a bottleneck. - - Also note that at some point, we thought about trying to reuse names of - variables which are not used anymore, like here: - {[ - let x = ... in - ... - let x0 = ... in // We could use the name "x" if [x] is not used below - ... - ]} - - However it is a good idea to keep things as they are for F*: as F* is - designed for extrinsic proofs, a proof about a function follows this - function's structure. The consequence is that we often end up - copy-pasting function bodies. As in the proofs (in assertions and - when calling lemmas) we often need to talk about the "past" (i.e., - previous values), it is very useful to generate code where all variable - names are assigned at most once. - - [append]: function to append an index to a string - *) -let basename_to_unique (names_set : StringSet.t) - (append : string -> int -> string) (basename : string) : string = - let rec gen (i : int) : string = - let s = append basename i in - if StringSet.mem s names_set then gen (i + 1) else s - in - if StringSet.mem basename names_set then gen 0 else basename - -(** Extraction context. - - Note that the extraction context contains information coming from the - LLBC AST (not only the pure AST). This is useful for naming, for instance: - we use the region information to generate the names of the backward - functions, etc. - *) -type extraction_ctx = { - trans_ctx : trans_ctx; - names_map : names_map; - fmt : formatter; - indent_incr : int; - (** The indent increment we insert whenever we need to indent more *) -} - -(** Debugging function *) -let id_to_string (id : id) (ctx : extraction_ctx) : string = - let global_decls = ctx.trans_ctx.global_context.global_decls in - let fun_decls = ctx.trans_ctx.fun_context.fun_decls in - let type_decls = ctx.trans_ctx.type_context.type_decls in - (* TODO: factorize the pretty-printing with what is in PrintPure *) - let get_type_name (id : type_id) : string = - match id with - | AdtId id -> - let def = TypeDeclId.Map.find id type_decls in - Print.name_to_string def.name - | Assumed aty -> show_assumed_ty aty - | Tuple -> failwith "Unreachable" - in - match id with - | GlobalId gid -> - let name = (A.GlobalDeclId.Map.find gid global_decls).name in - "global name: " ^ Print.global_name_to_string name - | FunId (fid, rg_id) -> - let fun_name = - match fid with - | A.Regular fid -> - Print.fun_name_to_string (A.FunDeclId.Map.find fid fun_decls).name - | A.Assumed aid -> A.show_assumed_fun_id aid - in - let fun_kind = - match rg_id with - | None -> "forward" - | Some rg_id -> "backward " ^ RegionGroupId.to_string rg_id - in - "fun name (" ^ fun_kind ^ "): " ^ fun_name - | DecreasesClauseId fid -> - let fun_name = - match fid with - | A.Regular fid -> - Print.fun_name_to_string (A.FunDeclId.Map.find fid fun_decls).name - | A.Assumed aid -> A.show_assumed_fun_id aid - in - "decreases clause for function: " ^ fun_name - | TypeId id -> "type name: " ^ get_type_name id - | StructId id -> "struct constructor of: " ^ get_type_name id - | VariantId (id, variant_id) -> - let variant_name = - match id with - | Tuple -> failwith "Unreachable" - | Assumed State -> failwith "Unreachable" - | Assumed Result -> - if variant_id = result_return_id then "@result::Return" - else if variant_id = result_fail_id then "@result::Fail" - else failwith "Unreachable" - | Assumed Option -> - if variant_id = option_some_id then "@option::Some" - else if variant_id = option_none_id then "@option::None" - else failwith "Unreachable" - | Assumed Vec -> failwith "Unreachable" - | AdtId id -> ( - let def = TypeDeclId.Map.find id type_decls in - match def.kind with - | Struct _ | Opaque -> failwith "Unreachable" - | Enum variants -> - let variant = VariantId.nth variants variant_id in - Print.name_to_string def.name ^ "::" ^ variant.variant_name) - in - "variant name: " ^ variant_name - | FieldId (id, field_id) -> - let field_name = - match id with - | Tuple -> failwith "Unreachable" - | Assumed (State | Result | Option) -> failwith "Unreachable" - | Assumed Vec -> - (* We can't directly have access to the fields of a vector *) - failwith "Unreachable" - | AdtId id -> ( - let def = TypeDeclId.Map.find id type_decls in - match def.kind with - | Enum _ | Opaque -> failwith "Unreachable" - | Struct fields -> - let field = FieldId.nth fields field_id in - let field_name = - match field.field_name with - | None -> FieldId.to_string field_id - | Some name -> name - in - Print.name_to_string def.name ^ "." ^ field_name) - in - "field name: " ^ field_name - | UnknownId -> "keyword" - | TypeVarId _ | VarId _ -> - (* We should never get there: we add indices to make sure variable - * names are unique *) - failwith "Unreachable" - -let ctx_add (id : id) (name : string) (ctx : extraction_ctx) : extraction_ctx = - (* The id_to_string function to print nice debugging messages if there are - * collisions *) - let id_to_string (id : id) : string = id_to_string id ctx in - let names_map = names_map_add id_to_string id name ctx.names_map in - { ctx with names_map } - -let ctx_get (id : id) (ctx : extraction_ctx) : string = - match IdMap.find_opt id ctx.names_map.id_to_name with - | Some s -> s - | None -> - log#serror ("Could not find: " ^ id_to_string id ctx); - raise Not_found - -let ctx_get_global (id : A.GlobalDeclId.id) (ctx : extraction_ctx) : string = - ctx_get (GlobalId id) ctx - -let ctx_get_function (id : A.fun_id) (rg : RegionGroupId.id option) - (ctx : extraction_ctx) : string = - ctx_get (FunId (id, rg)) ctx - -let ctx_get_local_function (id : A.FunDeclId.id) (rg : RegionGroupId.id option) - (ctx : extraction_ctx) : string = - ctx_get_function (A.Regular id) rg ctx - -let ctx_get_type (id : type_id) (ctx : extraction_ctx) : string = - assert (id <> Tuple); - ctx_get (TypeId id) ctx - -let ctx_get_local_type (id : TypeDeclId.id) (ctx : extraction_ctx) : string = - ctx_get_type (AdtId id) ctx - -let ctx_get_assumed_type (id : assumed_ty) (ctx : extraction_ctx) : string = - ctx_get_type (Assumed id) ctx - -let ctx_get_var (id : VarId.id) (ctx : extraction_ctx) : string = - ctx_get (VarId id) ctx - -let ctx_get_type_var (id : TypeVarId.id) (ctx : extraction_ctx) : string = - ctx_get (TypeVarId id) ctx - -let ctx_get_field (type_id : type_id) (field_id : FieldId.id) - (ctx : extraction_ctx) : string = - ctx_get (FieldId (type_id, field_id)) ctx - -let ctx_get_struct (def_id : type_id) (ctx : extraction_ctx) : string = - ctx_get (StructId def_id) ctx - -let ctx_get_variant (def_id : type_id) (variant_id : VariantId.id) - (ctx : extraction_ctx) : string = - ctx_get (VariantId (def_id, variant_id)) ctx - -let ctx_get_decreases_clause (def_id : A.FunDeclId.id) (ctx : extraction_ctx) : - string = - ctx_get (DecreasesClauseId (A.Regular def_id)) ctx - -(** Generate a unique type variable name and add it to the context *) -let ctx_add_type_var (basename : string) (id : TypeVarId.id) - (ctx : extraction_ctx) : extraction_ctx * string = - let name = ctx.fmt.type_var_basename ctx.names_map.names_set basename in - let name = - basename_to_unique ctx.names_map.names_set ctx.fmt.append_index name - in - let ctx = ctx_add (TypeVarId id) name ctx in - (ctx, name) - -(** See {!ctx_add_type_var} *) -let ctx_add_type_vars (vars : (string * TypeVarId.id) list) - (ctx : extraction_ctx) : extraction_ctx * string list = - List.fold_left_map - (fun ctx (name, id) -> ctx_add_type_var name id ctx) - ctx vars - -(** Generate a unique variable name and add it to the context *) -let ctx_add_var (basename : string) (id : VarId.id) (ctx : extraction_ctx) : - extraction_ctx * string = - let name = - basename_to_unique ctx.names_map.names_set ctx.fmt.append_index basename - in - let ctx = ctx_add (VarId id) name ctx in - (ctx, name) - -(** See {!ctx_add_var} *) -let ctx_add_vars (vars : var list) (ctx : extraction_ctx) : - extraction_ctx * string list = - List.fold_left_map - (fun ctx (v : var) -> - let name = ctx.fmt.var_basename ctx.names_map.names_set v.basename v.ty in - ctx_add_var name v.id ctx) - ctx vars - -let ctx_add_type_params (vars : type_var list) (ctx : extraction_ctx) : - extraction_ctx * string list = - List.fold_left_map - (fun ctx (var : type_var) -> ctx_add_type_var var.name var.index ctx) - ctx vars - -let ctx_add_type_decl_struct (def : type_decl) (ctx : extraction_ctx) : - extraction_ctx * string = - let cons_name = ctx.fmt.struct_constructor def.name in - let ctx = ctx_add (StructId (AdtId def.def_id)) cons_name ctx in - (ctx, cons_name) - -let ctx_add_type_decl (def : type_decl) (ctx : extraction_ctx) : extraction_ctx - = - let def_name = ctx.fmt.type_name def.name in - let ctx = ctx_add (TypeId (AdtId def.def_id)) def_name ctx in - ctx - -let ctx_add_field (def : type_decl) (field_id : FieldId.id) (field : field) - (ctx : extraction_ctx) : extraction_ctx * string = - let name = ctx.fmt.field_name def.name field_id field.field_name in - let ctx = ctx_add (FieldId (AdtId def.def_id, field_id)) name ctx in - (ctx, name) - -let ctx_add_fields (def : type_decl) (fields : (FieldId.id * field) list) - (ctx : extraction_ctx) : extraction_ctx * string list = - List.fold_left_map - (fun ctx (vid, v) -> ctx_add_field def vid v ctx) - ctx fields - -let ctx_add_variant (def : type_decl) (variant_id : VariantId.id) - (variant : variant) (ctx : extraction_ctx) : extraction_ctx * string = - let name = ctx.fmt.variant_name def.name variant.variant_name in - let ctx = ctx_add (VariantId (AdtId def.def_id, variant_id)) name ctx in - (ctx, name) - -let ctx_add_variants (def : type_decl) - (variants : (VariantId.id * variant) list) (ctx : extraction_ctx) : - extraction_ctx * string list = - List.fold_left_map - (fun ctx (vid, v) -> ctx_add_variant def vid v ctx) - ctx variants - -let ctx_add_struct (def : type_decl) (ctx : extraction_ctx) : - extraction_ctx * string = - let name = ctx.fmt.struct_constructor def.name in - let ctx = ctx_add (StructId (AdtId def.def_id)) name ctx in - (ctx, name) - -let ctx_add_decrases_clause (def : fun_decl) (ctx : extraction_ctx) : - extraction_ctx = - let name = ctx.fmt.decreases_clause_name def.def_id def.basename in - ctx_add (DecreasesClauseId (A.Regular def.def_id)) name ctx - -let ctx_add_global_decl_and_body (def : A.global_decl) (ctx : extraction_ctx) : - extraction_ctx = - let name = ctx.fmt.global_name def.name in - let decl = GlobalId def.def_id in - let body = FunId (Regular def.body_id, None) in - let ctx = ctx_add decl (name ^ "_c") ctx in - let ctx = ctx_add body (name ^ "_body") ctx in - ctx - -let ctx_add_fun_decl (trans_group : bool * pure_fun_translation) - (def : fun_decl) (ctx : extraction_ctx) : extraction_ctx = - (* Sanity check: the function should not be a global body - those are handled - * separately *) - assert (not def.is_global_decl_body); - (* Lookup the LLBC def to compute the region group information *) - let def_id = def.def_id in - let llbc_def = - A.FunDeclId.Map.find def_id ctx.trans_ctx.fun_context.fun_decls - in - let sg = llbc_def.signature in - let num_rgs = List.length sg.regions_hierarchy in - let keep_fwd, (_, backs) = trans_group in - let num_backs = List.length backs in - let rg_info = - match def.back_id with - | None -> None - | Some rg_id -> - let rg = T.RegionGroupId.nth sg.regions_hierarchy rg_id in - let regions = - List.map - (fun rid -> T.RegionVarId.nth sg.region_params rid) - rg.regions - in - let region_names = - List.map (fun (r : T.region_var) -> r.name) regions - in - Some { id = rg_id; region_names } - in - let def_id = A.Regular def_id in - let name = - ctx.fmt.fun_name def_id def.basename num_rgs rg_info (keep_fwd, num_backs) - in - ctx_add (FunId (def_id, def.back_id)) name ctx - -type names_map_init = { - keywords : string list; - assumed_adts : (assumed_ty * string) list; - assumed_structs : (assumed_ty * string) list; - assumed_variants : (assumed_ty * VariantId.id * string) list; - assumed_functions : (A.assumed_fun_id * RegionGroupId.id option * string) list; -} - -(** Initialize a names map with a proper set of keywords/names coming from the - target language/prover. *) -let initialize_names_map (init : names_map_init) : names_map = - let name_to_id = - StringMap.of_list (List.map (fun x -> (x, UnknownId)) init.keywords) - in - let names_set = StringSet.of_list init.keywords in - (* We fist initialize [id_to_name] as empty, because the id of a keyword is [UnknownId]. - * Also note that we don't need this mapping for keywords: we insert keywords only - * to check collisions. *) - let id_to_name = IdMap.empty in - let nm = { id_to_name; name_to_id; names_set } in - (* For debugging - we are creating bindings for assumed types and functions, so - * it is ok if we simply use the "show" function (those aren't simply identified - * by numbers) *) - let id_to_string = show_id in - (* Then we add: - * - the assumed types - * - the assumed struct constructors - * - the assumed variants - * - the assumed functions - *) - let nm = - List.fold_left - (fun nm (type_id, name) -> - names_map_add_assumed_type id_to_string type_id name nm) - nm init.assumed_adts - in - let nm = - List.fold_left - (fun nm (type_id, name) -> - names_map_add_assumed_struct id_to_string type_id name nm) - nm init.assumed_structs - in - let nm = - List.fold_left - (fun nm (type_id, variant_id, name) -> - names_map_add_assumed_variant id_to_string type_id variant_id name nm) - nm init.assumed_variants - in - let nm = - List.fold_left - (fun nm (fun_id, rg_id, name) -> - names_map_add_assumed_function id_to_string fun_id rg_id name nm) - nm init.assumed_functions - in - (* Return *) - nm - -let compute_type_decl_name (fmt : formatter) (def : type_decl) : string = - fmt.type_name def.name - -(** A helper function: generates a function suffix from a region group - information. - TODO: move all those helpers. -*) -let default_fun_suffix (num_region_groups : int) (rg : region_group_info option) - ((keep_fwd, num_backs) : bool * int) : string = - (* There are several cases: - - [rg] is [Some]: this is a forward function: - - we add "_fwd" - - [rg] is [None]: this is a backward function: - - this function has one extracted backward function: - - if the forward function has been filtered, we add "_fwd_back": - the forward function is useless, so the unique backward function - takes its place, in a way - - otherwise we add "_back" - - this function has several backward functions: we add "_back" and an - additional suffix to identify the precise backward function - Note that we always add a suffix (in case there are no region groups, - we could not add the "_fwd" suffix) to prevent name clashes between - definitions (in particular between type and function definitions). - *) - match rg with - | None -> "_fwd" - | Some rg -> - assert (num_region_groups > 0 && num_backs > 0); - if num_backs = 1 then - (* Exactly one backward function *) - if not keep_fwd then "_fwd_back" else "_back" - else if - (* Several region groups/backward functions: - - if all the regions in the group have names, we use those names - - otherwise we use an index - *) - List.for_all Option.is_some rg.region_names - then - (* Concatenate the region names *) - "_back" ^ String.concat "" (List.map Option.get rg.region_names) - else (* Use the region index *) - "_back" ^ RegionGroupId.to_string rg.id diff --git a/src/PureTypeCheck.ml b/src/PureTypeCheck.ml deleted file mode 100644 index caad8a58..00000000 --- a/src/PureTypeCheck.ml +++ /dev/null @@ -1,178 +0,0 @@ -(** Module to perform type checking on the pure AST - we use this for sanity checks only *) - -open Pure -open PureUtils - -(** Utility function, used for type checking *) -let get_adt_field_types (type_decls : type_decl TypeDeclId.Map.t) - (type_id : type_id) (variant_id : VariantId.id option) (tys : ty list) : - ty list = - match type_id with - | Tuple -> - (* Tuple *) - assert (variant_id = None); - tys - | AdtId def_id -> - (* "Regular" ADT *) - let def = TypeDeclId.Map.find def_id type_decls in - type_decl_get_instantiated_fields_types def variant_id tys - | Assumed aty -> ( - (* Assumed type *) - match aty with - | State -> - (* [State] is opaque *) - raise (Failure "Unreachable: `State` values are opaque") - | Result -> - let ty = Collections.List.to_cons_nil tys in - let variant_id = Option.get variant_id in - if variant_id = result_return_id then [ ty ] - else if variant_id = result_fail_id then [] - else - raise (Failure "Unreachable: improper variant id for result type") - | Option -> - let ty = Collections.List.to_cons_nil tys in - let variant_id = Option.get variant_id in - if variant_id = option_some_id then [ ty ] - else if variant_id = option_none_id then [] - else - raise (Failure "Unreachable: improper variant id for result type") - | Vec -> raise (Failure "Unreachable: `Vector` values are opaque")) - -type tc_ctx = { - type_decls : type_decl TypeDeclId.Map.t; (** The type declarations *) - global_decls : A.global_decl A.GlobalDeclId.Map.t; - (** The global declarations *) - env : ty VarId.Map.t; (** Environment from variables to types *) -} - -let check_constant_value (v : constant_value) (ty : ty) : unit = - match (ty, v) with - | Integer int_ty, V.Scalar sv -> assert (int_ty = sv.V.int_ty) - | Bool, Bool _ | Char, Char _ | Str, String _ -> () - | _ -> raise (Failure "Inconsistent type") - -let rec check_typed_pattern (ctx : tc_ctx) (v : typed_pattern) : tc_ctx = - log#ldebug (lazy ("check_typed_pattern: " ^ show_typed_pattern v)); - match v.value with - | PatConcrete cv -> - check_constant_value cv v.ty; - ctx - | PatDummy -> ctx - | PatVar (var, _) -> - assert (var.ty = v.ty); - let env = VarId.Map.add var.id var.ty ctx.env in - { ctx with env } - | PatAdt av -> - (* Compute the field types *) - let type_id, tys = - match v.ty with - | Adt (type_id, tys) -> (type_id, tys) - | _ -> raise (Failure "Inconsistently typed value") - in - let field_tys = - get_adt_field_types ctx.type_decls type_id av.variant_id tys - in - let check_value (ctx : tc_ctx) (ty : ty) (v : typed_pattern) : tc_ctx = - if ty <> v.ty then ( - log#serror - ("check_typed_pattern: not the same types:" ^ "\n- ty: " - ^ show_ty ty ^ "\n- v.ty: " ^ show_ty v.ty); - raise (Failure "Inconsistent types")); - check_typed_pattern ctx v - in - (* Check the field types: check that the field patterns have the expected - * types, and check that the field patterns themselves are well-typed *) - List.fold_left - (fun ctx (ty, v) -> check_value ctx ty v) - ctx - (List.combine field_tys av.field_values) - -let rec check_texpression (ctx : tc_ctx) (e : texpression) : unit = - match e.e with - | Var var_id -> ( - (* Lookup the variable - note that the variable may not be there, - * if we type-check a subexpression (i.e.: if the variable is introduced - * "outside" of the expression) - TODO: this won't happen once - * we use a locally nameless representation *) - match VarId.Map.find_opt var_id ctx.env with - | None -> () - | Some ty -> assert (ty = e.ty)) - | Const cv -> check_constant_value cv e.ty - | App (app, arg) -> - let input_ty, output_ty = destruct_arrow app.ty in - assert (input_ty = arg.ty); - assert (output_ty = e.ty); - check_texpression ctx app; - check_texpression ctx arg - | Abs (pat, body) -> - let pat_ty, body_ty = destruct_arrow e.ty in - assert (pat.ty = pat_ty); - assert (body.ty = body_ty); - (* Check the pattern and register the introduced variables at the same time *) - let ctx = check_typed_pattern ctx pat in - check_texpression ctx body - | Qualif qualif -> ( - match qualif.id with - | Func _ -> () (* TODO *) - | Global _ -> () (* TODO *) - | Proj { adt_id = proj_adt_id; field_id } -> - (* Note we can only project fields of structures (not enumerations) *) - (* Deconstruct the projector type *) - let adt_ty, field_ty = destruct_arrow e.ty in - let adt_id, adt_type_args = - match adt_ty with - | Adt (type_id, tys) -> (type_id, tys) - | _ -> raise (Failure "Unreachable") - in - (* Check the ADT type *) - assert (adt_id = proj_adt_id); - assert (adt_type_args = qualif.type_args); - (* Retrieve and check the expected field type *) - let variant_id = None in - let expected_field_tys = - get_adt_field_types ctx.type_decls proj_adt_id variant_id - qualif.type_args - in - let expected_field_ty = FieldId.nth expected_field_tys field_id in - assert (expected_field_ty = field_ty) - | AdtCons id -> ( - let expected_field_tys = - get_adt_field_types ctx.type_decls id.adt_id id.variant_id - qualif.type_args - in - let field_tys, adt_ty = destruct_arrows e.ty in - assert (expected_field_tys = field_tys); - match adt_ty with - | Adt (type_id, tys) -> - assert (type_id = id.adt_id); - assert (tys = qualif.type_args) - | _ -> raise (Failure "Unreachable"))) - | Let (monadic, pat, re, e_next) -> - let expected_pat_ty = if monadic then destruct_result re.ty else re.ty in - assert (pat.ty = expected_pat_ty); - assert (e.ty = e_next.ty); - (* Check the right-expression *) - check_texpression ctx re; - (* Check the pattern and register the introduced variables at the same time *) - let ctx = check_typed_pattern ctx pat in - (* Check the next expression *) - check_texpression ctx e_next - | Switch (scrut, switch_body) -> ( - check_texpression ctx scrut; - match switch_body with - | If (e_then, e_else) -> - assert (scrut.ty = Bool); - assert (e_then.ty = e.ty); - assert (e_else.ty = e.ty); - check_texpression ctx e_then; - check_texpression ctx e_else - | Match branches -> - let check_branch (br : match_branch) : unit = - assert (br.pat.ty = scrut.ty); - let ctx = check_typed_pattern ctx br.pat in - check_texpression ctx br.branch - in - List.iter check_branch branches) - | Meta (_, e_next) -> - assert (e_next.ty = e.ty); - check_texpression ctx e_next diff --git a/src/PureUtils.ml b/src/PureUtils.ml deleted file mode 100644 index 39f3d76a..00000000 --- a/src/PureUtils.ml +++ /dev/null @@ -1,450 +0,0 @@ -open Pure - -(** Default logger *) -let log = Logging.pure_utils_log - -(** We use this type as a key for lookups *) -type regular_fun_id = A.fun_id * T.RegionGroupId.id option -[@@deriving show, ord] - -module RegularFunIdOrderedType = struct - type t = regular_fun_id - - let compare = compare_regular_fun_id - let to_string = show_regular_fun_id - let pp_t = pp_regular_fun_id - let show_t = show_regular_fun_id -end - -module RegularFunIdMap = Collections.MakeMap (RegularFunIdOrderedType) - -module FunIdOrderedType = struct - type t = fun_id - - let compare = compare_fun_id - let to_string = show_fun_id - let pp_t = pp_fun_id - let show_t = show_fun_id -end - -module FunIdMap = Collections.MakeMap (FunIdOrderedType) -module FunIdSet = Collections.MakeSet (FunIdOrderedType) - -let dest_arrow_ty (ty : ty) : ty * ty = - match ty with - | Arrow (arg_ty, ret_ty) -> (arg_ty, ret_ty) - | _ -> raise (Failure "Unreachable") - -let compute_constant_value_ty (cv : constant_value) : ty = - match cv with - | V.Scalar sv -> Integer sv.V.int_ty - | Bool _ -> Bool - | Char _ -> Char - | String _ -> Str - -let mk_typed_pattern_from_constant_value (cv : constant_value) : typed_pattern = - let ty = compute_constant_value_ty cv in - { value = PatConcrete cv; ty } - -let mk_let (monadic : bool) (lv : typed_pattern) (re : texpression) - (next_e : texpression) : texpression = - let e = Let (monadic, lv, re, next_e) in - let ty = next_e.ty in - { e; ty } - -(** Type substitution *) -let ty_substitute (tsubst : TypeVarId.id -> ty) (ty : ty) : ty = - let obj = - object - inherit [_] map_ty - method! visit_TypeVar _ var_id = tsubst var_id - end - in - obj#visit_ty () ty - -let make_type_subst (vars : type_var list) (tys : ty list) : TypeVarId.id -> ty - = - let ls = List.combine vars tys in - let mp = - List.fold_left - (fun mp (k, v) -> TypeVarId.Map.add (k : type_var).index v mp) - TypeVarId.Map.empty ls - in - fun id -> TypeVarId.Map.find id mp - -(** Retrieve the list of fields for the given variant of a {!Pure.type_decl}. - - Raises [Invalid_argument] if the arguments are incorrect. - *) -let type_decl_get_fields (def : type_decl) - (opt_variant_id : VariantId.id option) : field list = - match (def.kind, opt_variant_id) with - | Enum variants, Some variant_id -> (VariantId.nth variants variant_id).fields - | Struct fields, None -> fields - | _ -> - let opt_variant_id = - match opt_variant_id with None -> "None" | Some _ -> "Some" - in - raise - (Invalid_argument - ("The variant id should be [Some] if and only if the definition is \ - an enumeration:\n\ - - def: " ^ show_type_decl def ^ "\n- opt_variant_id: " - ^ opt_variant_id)) - -(** Instantiate the type variables for the chosen variant in an ADT definition, - and return the list of the types of its fields *) -let type_decl_get_instantiated_fields_types (def : type_decl) - (opt_variant_id : VariantId.id option) (types : ty list) : ty list = - let ty_subst = make_type_subst def.type_params types in - let fields = type_decl_get_fields def opt_variant_id in - List.map (fun f -> ty_substitute ty_subst f.field_ty) fields - -let fun_sig_substitute (tsubst : TypeVarId.id -> ty) (sg : fun_sig) : - inst_fun_sig = - let subst = ty_substitute tsubst in - let inputs = List.map subst sg.inputs in - let output = subst sg.output in - let doutputs = List.map subst sg.doutputs in - let info = sg.info in - { inputs; output; doutputs; info } - -(** Return true if a list of functions are *not* mutually recursive, false otherwise. - This function is meant to be applied on a set of (forward, backwards) functions - generated for one recursive function. - The way we do the test is very simple: - - we explore the functions one by one, in the order - - if all functions only call functions we already explored, they are not - mutually recursive - *) -let functions_not_mutually_recursive (funs : fun_decl list) : bool = - (* Compute the set of function identifiers in the group *) - let ids = - FunIdSet.of_list - (List.map - (fun (f : fun_decl) -> Regular (A.Regular f.def_id, f.back_id)) - funs) - in - let ids = ref ids in - (* Explore every body *) - let body_only_calls_itself (fdef : fun_decl) : bool = - (* Remove the current id from the id set *) - ids := FunIdSet.remove (Regular (A.Regular fdef.def_id, fdef.back_id)) !ids; - - (* Check if we call functions from the updated id set *) - let obj = - object - inherit [_] iter_expression as super - - method! visit_qualif env qualif = - match qualif.id with - | Func fun_id -> - if FunIdSet.mem fun_id !ids then raise Utils.Found - else super#visit_qualif env qualif - | _ -> super#visit_qualif env qualif - end - in - - try - match fdef.body with - | None -> true - | Some body -> - obj#visit_texpression () body.body; - true - with Utils.Found -> false - in - List.for_all body_only_calls_itself funs - -(** We use this to check whether we need to add parentheses around expressions. - We only look for outer monadic let-bindings. - This is used when printing the branches of [if ... then ... else ...]. - *) -let rec let_group_requires_parentheses (e : texpression) : bool = - match e.e with - | Var _ | Const _ | App _ | Abs _ | Qualif _ -> false - | Let (monadic, _, _, next_e) -> - if monadic then true else let_group_requires_parentheses next_e - | Switch (_, _) -> false - | Meta (_, next_e) -> let_group_requires_parentheses next_e - -let is_var (e : texpression) : bool = - match e.e with Var _ -> true | _ -> false - -let as_var (e : texpression) : VarId.id = - match e.e with Var v -> v | _ -> raise (Failure "Unreachable") - -let is_global (e : texpression) : bool = - match e.e with Qualif { id = Global _; _ } -> true | _ -> false - -let is_const (e : texpression) : bool = - match e.e with Const _ -> true | _ -> false - -(** Remove the external occurrences of {!Meta} *) -let rec unmeta (e : texpression) : texpression = - match e.e with Meta (_, e) -> unmeta e | _ -> e - -(** Remove *all* the meta information *) -let remove_meta (e : texpression) : texpression = - let obj = - object - inherit [_] map_expression as super - method! visit_Meta env _ e = super#visit_expression env e.e - end - in - obj#visit_texpression () e - -let mk_arrow (ty0 : ty) (ty1 : ty) : ty = Arrow (ty0, ty1) - -(** Construct a type as a list of arrows: ty1 -> ... tyn *) -let mk_arrows (inputs : ty list) (output : ty) = - let rec aux (tys : ty list) : ty = - match tys with [] -> output | ty :: tys' -> Arrow (ty, aux tys') - in - aux inputs - -(** Destruct an [App] expression into an expression and a list of arguments. - - We simply destruct the expression as long as it is of the form [App (f, x)]. - *) -let destruct_apps (e : texpression) : texpression * texpression list = - let rec aux (args : texpression list) (e : texpression) : - texpression * texpression list = - match e.e with App (f, x) -> aux (x :: args) f | _ -> (e, args) - in - aux [] e - -(** Make an [App (app, arg)] expression *) -let mk_app (app : texpression) (arg : texpression) : texpression = - match app.ty with - | Arrow (ty0, ty1) -> - (* Sanity check *) - assert (ty0 = arg.ty); - let e = App (app, arg) in - let ty = ty1 in - { e; ty } - | _ -> raise (Failure "Expected an arrow type") - -(** The reverse of {!destruct_apps} *) -let mk_apps (app : texpression) (args : texpression list) : texpression = - List.fold_left (fun app arg -> mk_app app arg) app args - -(** Destruct an expression into a qualif identifier and a list of arguments, - * if possible *) -let opt_destruct_qualif_app (e : texpression) : - (qualif * texpression list) option = - let app, args = destruct_apps e in - match app.e with Qualif qualif -> Some (qualif, args) | _ -> None - -(** Destruct an expression into a qualif identifier and a list of arguments *) -let destruct_qualif_app (e : texpression) : qualif * texpression list = - Option.get (opt_destruct_qualif_app e) - -(** Destruct an expression into a function call, if possible *) -let opt_destruct_function_call (e : texpression) : - (fun_id * ty list * texpression list) option = - match opt_destruct_qualif_app e with - | None -> None - | Some (qualif, args) -> ( - match qualif.id with - | Func fun_id -> Some (fun_id, qualif.type_args, args) - | _ -> None) - -let opt_destruct_result (ty : ty) : ty option = - match ty with - | Adt (Assumed Result, tys) -> Some (Collections.List.to_cons_nil tys) - | _ -> None - -let destruct_result (ty : ty) : ty = Option.get (opt_destruct_result ty) - -let opt_destruct_tuple (ty : ty) : ty list option = - match ty with Adt (Tuple, tys) -> Some tys | _ -> None - -let mk_abs (x : typed_pattern) (e : texpression) : texpression = - let ty = Arrow (x.ty, e.ty) in - let e = Abs (x, e) in - { e; ty } - -let rec destruct_abs_list (e : texpression) : typed_pattern list * texpression = - match e.e with - | Abs (x, e') -> - let xl, e'' = destruct_abs_list e' in - (x :: xl, e'') - | _ -> ([], e) - -let destruct_arrow (ty : ty) : ty * ty = - match ty with - | Arrow (ty0, ty1) -> (ty0, ty1) - | _ -> raise (Failure "Not an arrow type") - -let rec destruct_arrows (ty : ty) : ty list * ty = - match ty with - | Arrow (ty0, ty1) -> - let tys, out_ty = destruct_arrows ty1 in - (ty0 :: tys, out_ty) - | _ -> ([], ty) - -let get_switch_body_ty (sb : switch_body) : ty = - match sb with - | If (e_then, _) -> e_then.ty - | Match branches -> - (* There should be at least one branch *) - (List.hd branches).branch.ty - -let map_switch_body_branches (f : texpression -> texpression) (sb : switch_body) - : switch_body = - match sb with - | If (e_then, e_else) -> If (f e_then, f e_else) - | Match branches -> - Match - (List.map - (fun (b : match_branch) -> { b with branch = f b.branch }) - branches) - -let iter_switch_body_branches (f : texpression -> unit) (sb : switch_body) : - unit = - match sb with - | If (e_then, e_else) -> - f e_then; - f e_else - | Match branches -> List.iter (fun (b : match_branch) -> f b.branch) branches - -let mk_switch (scrut : texpression) (sb : switch_body) : texpression = - (* Sanity check: the scrutinee has the proper type *) - (match sb with - | If (_, _) -> assert (scrut.ty = Bool) - | Match branches -> - List.iter - (fun (b : match_branch) -> assert (b.pat.ty = scrut.ty)) - branches); - (* Sanity check: all the branches have the same type *) - let ty = get_switch_body_ty sb in - iter_switch_body_branches (fun e -> assert (e.ty = ty)) sb; - (* Put together *) - let e = Switch (scrut, sb) in - { e; ty } - -(** Make a "simplified" tuple type from a list of types: - - if there is exactly one type, just return it - - if there is > one type: wrap them in a tuple - *) -let mk_simpl_tuple_ty (tys : ty list) : ty = - match tys with [ ty ] -> ty | _ -> Adt (Tuple, tys) - -let mk_unit_ty : ty = Adt (Tuple, []) - -let mk_unit_rvalue : texpression = - let id = AdtCons { adt_id = Tuple; variant_id = None } in - let qualif = { id; type_args = [] } in - let e = Qualif qualif in - let ty = mk_unit_ty in - { e; ty } - -let mk_texpression_from_var (v : var) : texpression = - let e = Var v.id in - let ty = v.ty in - { e; ty } - -let mk_typed_pattern_from_var (v : var) (mp : mplace option) : typed_pattern = - let value = PatVar (v, mp) in - let ty = v.ty in - { value; ty } - -let mk_meta (m : meta) (e : texpression) : texpression = - let ty = e.ty in - let e = Meta (m, e) in - { e; ty } - -let mk_mplace_texpression (mp : mplace) (e : texpression) : texpression = - mk_meta (MPlace mp) e - -let mk_opt_mplace_texpression (mp : mplace option) (e : texpression) : - texpression = - match mp with None -> e | Some mp -> mk_mplace_texpression mp e - -(** Make a "simplified" tuple value from a list of values: - - if there is exactly one value, just return it - - if there is > one value: wrap them in a tuple - *) -let mk_simpl_tuple_pattern (vl : typed_pattern list) : typed_pattern = - match vl with - | [ v ] -> v - | _ -> - let tys = List.map (fun (v : typed_pattern) -> v.ty) vl in - let ty = Adt (Tuple, tys) in - let value = PatAdt { variant_id = None; field_values = vl } in - { value; ty } - -(** Similar to {!mk_simpl_tuple_pattern} *) -let mk_simpl_tuple_texpression (vl : texpression list) : texpression = - match vl with - | [ v ] -> v - | _ -> - (* Compute the types of the fields, and the type of the tuple constructor *) - let tys = List.map (fun (v : texpression) -> v.ty) vl in - let ty = Adt (Tuple, tys) in - let ty = mk_arrows tys ty in - (* Construct the tuple constructor qualifier *) - let id = AdtCons { adt_id = Tuple; variant_id = None } in - let qualif = { id; type_args = tys } in - (* Put everything together *) - let cons = { e = Qualif qualif; ty } in - mk_apps cons vl - -let mk_adt_pattern (adt_ty : ty) (variant_id : VariantId.id) - (vl : typed_pattern list) : typed_pattern = - let value = PatAdt { variant_id = Some variant_id; field_values = vl } in - { value; ty = adt_ty } - -let ty_as_integer (t : ty) : T.integer_type = - match t with Integer int_ty -> int_ty | _ -> raise (Failure "Unreachable") - -(* TODO: move *) -let type_decl_is_enum (def : T.type_decl) : bool = - match def.kind with T.Struct _ -> false | Enum _ -> true | Opaque -> false - -let mk_state_ty : ty = Adt (Assumed State, []) -let mk_result_ty (ty : ty) : ty = Adt (Assumed Result, [ ty ]) - -let unwrap_result_ty (ty : ty) : ty = - match ty with - | Adt (Assumed Result, [ ty ]) -> ty - | _ -> failwith "not a result type" - -let mk_result_fail_texpression (ty : ty) : texpression = - let type_args = [ ty ] in - let ty = Adt (Assumed Result, type_args) in - let id = - AdtCons { adt_id = Assumed Result; variant_id = Some result_fail_id } - in - let qualif = { id; type_args } in - let cons_e = Qualif qualif in - let cons_ty = ty in - let cons = { e = cons_e; ty = cons_ty } in - cons - -let mk_result_return_texpression (v : texpression) : texpression = - let type_args = [ v.ty ] in - let ty = Adt (Assumed Result, type_args) in - let id = - AdtCons { adt_id = Assumed Result; variant_id = Some result_return_id } - in - let qualif = { id; type_args } in - let cons_e = Qualif qualif in - let cons_ty = mk_arrow v.ty ty in - let cons = { e = cons_e; ty = cons_ty } in - mk_app cons v - -let mk_result_fail_pattern (ty : ty) : typed_pattern = - let ty = Adt (Assumed Result, [ ty ]) in - let value = PatAdt { variant_id = Some result_fail_id; field_values = [] } in - { value; ty } - -let mk_result_return_pattern (v : typed_pattern) : typed_pattern = - let ty = Adt (Assumed Result, [ v.ty ]) in - let value = - PatAdt { variant_id = Some result_return_id; field_values = [ v ] } - in - { value; ty } - -let opt_unmeta_mplace (e : texpression) : mplace option * texpression = - match e.e with Meta (MPlace mp, e) -> (Some mp, e) | _ -> (None, e) diff --git a/src/Scalars.ml b/src/Scalars.ml deleted file mode 100644 index 03ca506c..00000000 --- a/src/Scalars.ml +++ /dev/null @@ -1,59 +0,0 @@ -open Types -open Values - -(** The minimum/maximum values an integer type can have depending on its type *) - -let i8_min = Z.of_string "-128" -let i8_max = Z.of_string "127" -let i16_min = Z.of_string "-32768" -let i16_max = Z.of_string "32767" -let i32_min = Z.of_string "-2147483648" -let i32_max = Z.of_string "2147483647" -let i64_min = Z.of_string "-9223372036854775808" -let i64_max = Z.of_string "9223372036854775807" -let i128_min = Z.of_string "-170141183460469231731687303715884105728" -let i128_max = Z.of_string "170141183460469231731687303715884105727" -let u8_min = Z.of_string "0" -let u8_max = Z.of_string "255" -let u16_min = Z.of_string "0" -let u16_max = Z.of_string "65535" -let u32_min = Z.of_string "0" -let u32_max = Z.of_string "4294967295" -let u64_min = Z.of_string "0" -let u64_max = Z.of_string "18446744073709551615" -let u128_min = Z.of_string "0" -let u128_max = Z.of_string "340282366920938463463374607431768211455" - -(** Being a bit conservative about isize/usize: depending on the system, - the values are encoded as 32-bit values or 64-bit values - we may - want to take that into account in the future *) - -let isize_min = i32_min -let isize_max = i32_max -let usize_min = u32_min -let usize_max = u32_max - -(** Check that an integer value is in range *) -let check_int_in_range (int_ty : integer_type) (i : big_int) : bool = - match int_ty with - | Isize -> Z.leq isize_min i && Z.leq i isize_max - | I8 -> Z.leq i8_min i && Z.leq i i8_max - | I16 -> Z.leq i16_min i && Z.leq i i16_max - | I32 -> Z.leq i32_min i && Z.leq i i32_max - | I64 -> Z.leq i64_min i && Z.leq i i64_max - | I128 -> Z.leq i128_min i && Z.leq i i128_max - | Usize -> Z.leq usize_min i && Z.leq i usize_max - | U8 -> Z.leq u8_min i && Z.leq i u8_max - | U16 -> Z.leq u16_min i && Z.leq i u16_max - | U32 -> Z.leq u32_min i && Z.leq i u32_max - | U64 -> Z.leq u64_min i && Z.leq i u64_max - | U128 -> Z.leq u128_min i && Z.leq i u128_max - -(** Check that a scalar value is correct (the integer value it contains is in range) *) -let check_scalar_value_in_range (v : scalar_value) : bool = - check_int_in_range v.int_ty v.value - -(** Make a scalar value, while checking the value is in range *) -let mk_scalar (int_ty : integer_type) (i : big_int) : - (scalar_value, unit) result = - if check_int_in_range int_ty i then Ok { value = i; int_ty } else Error () diff --git a/src/StringUtils.ml b/src/StringUtils.ml deleted file mode 100644 index 0fd46136..00000000 --- a/src/StringUtils.ml +++ /dev/null @@ -1,106 +0,0 @@ -(** Utilities to work on strings, character per character. - - They operate on ASCII strings, and are used by the project to convert - Rust names: Rust names are not fancy, so it shouldn't be a problem. - - Rk.: the poor support of OCaml for char manipulation is really annoying... - *) - -let code_0 = 48 -let code_9 = 57 -let code_A = 65 -let code_Z = 90 -let code_a = 97 -let code_z = 122 - -let is_lowercase_ascii (c : char) : bool = - let c = Char.code c in - code_a <= c && c <= code_z - -let is_uppercase_ascii (c : char) : bool = - let c = Char.code c in - code_A <= c && c <= code_Z - -let is_letter_ascii (c : char) : bool = - is_lowercase_ascii c || is_uppercase_ascii c - -let is_digit_ascii (c : char) : bool = - let c = Char.code c in - code_0 <= c && c <= code_9 - -let lowercase_ascii = Char.lowercase_ascii -let uppercase_ascii = Char.uppercase_ascii - -(** Using buffers as per: - {{: https://stackoverflow.com/questions/29957418/how-to-convert-char-list-to-string-in-ocaml} stackoverflow} - *) -let string_of_chars (chars : char list) : string = - let buf = Buffer.create (List.length chars) in - List.iter (Buffer.add_char buf) chars; - Buffer.contents buf - -let string_to_chars (s : string) : char list = - let length = String.length s in - let rec apply i = - if i = length then [] else String.get s i :: apply (i + 1) - in - apply 0 - -(** This operates on ASCII *) -let to_camel_case (s : string) : string = - (* Note that we rebuild the string in reverse order *) - let apply ((prev_is_under, acc) : bool * char list) (c : char) : - bool * char list = - if c = '_' then (true, acc) - else - let c = if prev_is_under then uppercase_ascii c else c in - (false, c :: acc) - in - let _, chars = List.fold_left apply (true, []) (string_to_chars s) in - string_of_chars (List.rev chars) - -(** This operates on ASCII *) -let to_snake_case (s : string) : string = - (* Note that we rebuild the string in reverse order *) - let apply ((prev_is_low, prev_is_digit, acc) : bool * bool * char list) - (c : char) : bool * bool * char list = - let acc = - if c = '_' then acc - else if prev_is_digit then if is_letter_ascii c then '_' :: acc else acc - else if prev_is_low then - if (is_lowercase_ascii c || is_digit_ascii c) && c <> '_' then acc - else '_' :: acc - else acc - in - let prev_is_low = is_lowercase_ascii c in - let prev_is_digit = is_digit_ascii c in - let c = lowercase_ascii c in - (prev_is_low, prev_is_digit, c :: acc) - in - let _, _, chars = - List.fold_left apply (false, false, []) (string_to_chars s) - in - string_of_chars (List.rev chars) - -(** Applies a map operation. - - This is very inefficient, but shouldn't be used much. - *) -let map (f : char -> string) (s : string) : string = - let sl = List.map f (string_to_chars s) in - let sl = List.map string_to_chars sl in - string_of_chars (List.concat sl) - -let capitalize_first_letter (s : string) : string = - let s = string_to_chars s in - let s = match s with [] -> s | c :: s' -> uppercase_ascii c :: s' in - string_of_chars s - -(** Unit tests *) -let _ = - assert (to_camel_case "hello_world" = "HelloWorld"); - assert (to_snake_case "HelloWorld36Hello" = "hello_world36_hello"); - assert (to_snake_case "HELLO" = "hello"); - assert (to_snake_case "T1" = "t1"); - assert (to_camel_case "list" = "List"); - assert (to_snake_case "is_cons" = "is_cons") diff --git a/src/Substitute.ml b/src/Substitute.ml deleted file mode 100644 index 5e5858de..00000000 --- a/src/Substitute.ml +++ /dev/null @@ -1,357 +0,0 @@ -(** This file implements various substitution utilities to instantiate types, - function bodies, etc. - *) - -module T = Types -module TU = TypesUtils -module V = Values -module E = Expressions -module A = LlbcAst -module C = Contexts - -(** Substitute types variables and regions in a type. - - TODO: we can reimplement that with visitors. - *) -let rec ty_substitute (rsubst : 'r1 -> 'r2) - (tsubst : T.TypeVarId.id -> 'r2 T.ty) (ty : 'r1 T.ty) : 'r2 T.ty = - let open T in - let subst = ty_substitute rsubst tsubst in - (* helper *) - match ty with - | Adt (def_id, regions, tys) -> - Adt (def_id, List.map rsubst regions, List.map subst tys) - | Array aty -> Array (subst aty) - | Slice sty -> Slice (subst sty) - | Ref (r, ref_ty, ref_kind) -> Ref (rsubst r, subst ref_ty, ref_kind) - (* Below variants: we technically return the same value, but because - one has type ['r1 ty] and the other has type ['r2 ty], we need to - deconstruct then reconstruct *) - | Bool -> Bool - | Char -> Char - | Never -> Never - | Integer int_ty -> Integer int_ty - | Str -> Str - | TypeVar vid -> tsubst vid - -(** Convert an {!T.rty} to an {!T.ety} by erasing the region variables *) -let erase_regions (ty : T.rty) : T.ety = - ty_substitute (fun _ -> T.Erased) (fun vid -> T.TypeVar vid) ty - -(** Generate fresh regions for region variables. - - Return the list of new regions and appropriate substitutions from the - original region variables to the fresh regions. - - TODO: simplify? we only need the subst [T.RegionVarId.id -> T.RegionId.id] - *) -let fresh_regions_with_substs (region_vars : T.region_var list) : - T.RegionId.id list - * (T.RegionVarId.id -> T.RegionId.id) - * (T.RegionVarId.id T.region -> T.RegionId.id T.region) = - (* Generate fresh regions *) - let fresh_region_ids = List.map (fun _ -> C.fresh_region_id ()) region_vars in - (* Generate the map from region var ids to regions *) - let ls = List.combine region_vars fresh_region_ids in - let rid_map = - List.fold_left - (fun mp (k, v) -> T.RegionVarId.Map.add k.T.index v mp) - T.RegionVarId.Map.empty ls - in - (* Generate the substitution from region var id to region *) - let rid_subst id = T.RegionVarId.Map.find id rid_map in - (* Generate the substitution from region to region *) - let rsubst r = - match r with T.Static -> T.Static | T.Var id -> T.Var (rid_subst id) - in - (* Return *) - (fresh_region_ids, rid_subst, rsubst) - -(** Erase the regions in a type and substitute the type variables *) -let erase_regions_substitute_types (tsubst : T.TypeVarId.id -> T.ety) - (ty : 'r T.region T.ty) : T.ety = - let rsubst (_ : 'r T.region) : T.erased_region = T.Erased in - ty_substitute rsubst tsubst ty - -(** Create a region substitution from a list of region variable ids and a list of - regions (with which to substitute the region variable ids *) -let make_region_subst (var_ids : T.RegionVarId.id list) - (regions : 'r T.region list) : T.RegionVarId.id T.region -> 'r T.region = - let ls = List.combine var_ids regions in - let mp = - List.fold_left - (fun mp (k, v) -> T.RegionVarId.Map.add k v mp) - T.RegionVarId.Map.empty ls - in - fun r -> - match r with - | T.Static -> T.Static - | T.Var id -> T.RegionVarId.Map.find id mp - -(** Create a type substitution from a list of type variable ids and a list of - types (with which to substitute the type variable ids) *) -let make_type_subst (var_ids : T.TypeVarId.id list) (tys : 'r T.ty list) : - T.TypeVarId.id -> 'r T.ty = - let ls = List.combine var_ids tys in - let mp = - List.fold_left - (fun mp (k, v) -> T.TypeVarId.Map.add k v mp) - T.TypeVarId.Map.empty ls - in - fun id -> T.TypeVarId.Map.find id mp - -(** Instantiate the type variables in an ADT definition, and return, for - every variant, the list of the types of its fields *) -let type_decl_get_instantiated_variants_fields_rtypes (def : T.type_decl) - (regions : T.RegionId.id T.region list) (types : T.rty list) : - (T.VariantId.id option * T.rty list) list = - let r_subst = - make_region_subst - (List.map (fun x -> x.T.index) def.T.region_params) - regions - in - let ty_subst = - make_type_subst (List.map (fun x -> x.T.index) def.T.type_params) types - in - let (variants_fields : (T.VariantId.id option * T.field list) list) = - match def.T.kind with - | T.Enum variants -> - List.mapi - (fun i v -> (Some (T.VariantId.of_int i), v.T.fields)) - variants - | T.Struct fields -> [ (None, fields) ] - | T.Opaque -> - raise - (Failure - ("Can't retrieve the variants of an opaque type: " - ^ Names.name_to_string def.name)) - in - List.map - (fun (id, fields) -> - ( id, - List.map (fun f -> ty_substitute r_subst ty_subst f.T.field_ty) fields - )) - variants_fields - -(** Instantiate the type variables in an ADT definition, and return the list - of types of the fields for the chosen variant *) -let type_decl_get_instantiated_field_rtypes (def : T.type_decl) - (opt_variant_id : T.VariantId.id option) - (regions : T.RegionId.id T.region list) (types : T.rty list) : T.rty list = - let r_subst = - make_region_subst - (List.map (fun x -> x.T.index) def.T.region_params) - regions - in - let ty_subst = - make_type_subst (List.map (fun x -> x.T.index) def.T.type_params) types - in - let fields = TU.type_decl_get_fields def opt_variant_id in - List.map (fun f -> ty_substitute r_subst ty_subst f.T.field_ty) fields - -(** Return the types of the properly instantiated ADT's variant, provided a - context *) -let ctx_adt_get_instantiated_field_rtypes (ctx : C.eval_ctx) - (def_id : T.TypeDeclId.id) (opt_variant_id : T.VariantId.id option) - (regions : T.RegionId.id T.region list) (types : T.rty list) : T.rty list = - let def = C.ctx_lookup_type_decl ctx def_id in - type_decl_get_instantiated_field_rtypes def opt_variant_id regions types - -(** Return the types of the properly instantiated ADT value (note that - here, ADT is understood in its broad meaning: ADT, assumed value or tuple) *) -let ctx_adt_value_get_instantiated_field_rtypes (ctx : C.eval_ctx) - (adt : V.adt_value) (id : T.type_id) - (region_params : T.RegionId.id T.region list) (type_params : T.rty list) : - T.rty list = - match id with - | T.AdtId id -> - (* Retrieve the types of the fields *) - ctx_adt_get_instantiated_field_rtypes ctx id adt.V.variant_id - region_params type_params - | T.Tuple -> - assert (List.length region_params = 0); - type_params - | T.Assumed aty -> ( - match aty with - | T.Box | T.Vec -> - assert (List.length region_params = 0); - assert (List.length type_params = 1); - type_params - | T.Option -> - assert (List.length region_params = 0); - assert (List.length type_params = 1); - if adt.V.variant_id = Some T.option_some_id then type_params - else if adt.V.variant_id = Some T.option_none_id then [] - else failwith "Unrechable") - -(** Instantiate the type variables in an ADT definition, and return the list - of types of the fields for the chosen variant *) -let type_decl_get_instantiated_field_etypes (def : T.type_decl) - (opt_variant_id : T.VariantId.id option) (types : T.ety list) : T.ety list = - let ty_subst = - make_type_subst (List.map (fun x -> x.T.index) def.T.type_params) types - in - let fields = TU.type_decl_get_fields def opt_variant_id in - List.map - (fun f -> erase_regions_substitute_types ty_subst f.T.field_ty) - fields - -(** Return the types of the properly instantiated ADT's variant, provided a - context *) -let ctx_adt_get_instantiated_field_etypes (ctx : C.eval_ctx) - (def_id : T.TypeDeclId.id) (opt_variant_id : T.VariantId.id option) - (types : T.ety list) : T.ety list = - let def = C.ctx_lookup_type_decl ctx def_id in - type_decl_get_instantiated_field_etypes def opt_variant_id types - -(** Apply a type substitution to a place *) -let place_substitute (_tsubst : T.TypeVarId.id -> T.ety) (p : E.place) : E.place - = - (* There is nothing to do *) - p - -(** Apply a type substitution to an operand *) -let operand_substitute (tsubst : T.TypeVarId.id -> T.ety) (op : E.operand) : - E.operand = - let p_subst = place_substitute tsubst in - match op with - | E.Copy p -> E.Copy (p_subst p) - | E.Move p -> E.Move (p_subst p) - | E.Constant (ety, cv) -> - let rsubst x = x in - E.Constant (ty_substitute rsubst tsubst ety, cv) - -(** Apply a type substitution to an rvalue *) -let rvalue_substitute (tsubst : T.TypeVarId.id -> T.ety) (rv : E.rvalue) : - E.rvalue = - let op_subst = operand_substitute tsubst in - let p_subst = place_substitute tsubst in - match rv with - | E.Use op -> E.Use (op_subst op) - | E.Ref (p, bkind) -> E.Ref (p_subst p, bkind) - | E.UnaryOp (unop, op) -> E.UnaryOp (unop, op_subst op) - | E.BinaryOp (binop, op1, op2) -> - E.BinaryOp (binop, op_subst op1, op_subst op2) - | E.Discriminant p -> E.Discriminant (p_subst p) - | E.Aggregate (kind, ops) -> - let ops = List.map op_subst ops in - let kind = - match kind with - | E.AggregatedTuple -> E.AggregatedTuple - | E.AggregatedOption (variant_id, ty) -> - let rsubst r = r in - E.AggregatedOption (variant_id, ty_substitute rsubst tsubst ty) - | E.AggregatedAdt (def_id, variant_id, regions, tys) -> - let rsubst r = r in - E.AggregatedAdt - ( def_id, - variant_id, - regions, - List.map (ty_substitute rsubst tsubst) tys ) - in - E.Aggregate (kind, ops) - -(** Apply a type substitution to an assertion *) -let assertion_substitute (tsubst : T.TypeVarId.id -> T.ety) (a : A.assertion) : - A.assertion = - { A.cond = operand_substitute tsubst a.A.cond; A.expected = a.A.expected } - -(** Apply a type substitution to a call *) -let call_substitute (tsubst : T.TypeVarId.id -> T.ety) (call : A.call) : A.call - = - let rsubst x = x in - let type_args = List.map (ty_substitute rsubst tsubst) call.A.type_args in - let args = List.map (operand_substitute tsubst) call.A.args in - let dest = place_substitute tsubst call.A.dest in - (* Putting all the paramters on purpose: we want to get a compiler error if - something moves - we may add a field on which we need to apply a substitution *) - { - func = call.A.func; - region_args = call.A.region_args; - A.type_args; - args; - dest; - } - -(** Apply a type substitution to a statement *) -let rec statement_substitute (tsubst : T.TypeVarId.id -> T.ety) - (st : A.statement) : A.statement = - { st with A.content = raw_statement_substitute tsubst st.content } - -and raw_statement_substitute (tsubst : T.TypeVarId.id -> T.ety) - (st : A.raw_statement) : A.raw_statement = - match st with - | A.Assign (p, rvalue) -> - let p = place_substitute tsubst p in - let rvalue = rvalue_substitute tsubst rvalue in - A.Assign (p, rvalue) - | A.AssignGlobal g -> - (* Globals don't have type parameters *) - A.AssignGlobal g - | A.FakeRead p -> - let p = place_substitute tsubst p in - A.FakeRead p - | A.SetDiscriminant (p, vid) -> - let p = place_substitute tsubst p in - A.SetDiscriminant (p, vid) - | A.Drop p -> - let p = place_substitute tsubst p in - A.Drop p - | A.Assert assertion -> - let assertion = assertion_substitute tsubst assertion in - A.Assert assertion - | A.Call call -> - let call = call_substitute tsubst call in - A.Call call - | A.Panic | A.Return | A.Break _ | A.Continue _ | A.Nop -> st - | A.Sequence (st1, st2) -> - A.Sequence - (statement_substitute tsubst st1, statement_substitute tsubst st2) - | A.Switch (op, tgts) -> - A.Switch - (operand_substitute tsubst op, switch_targets_substitute tsubst tgts) - | A.Loop le -> A.Loop (statement_substitute tsubst le) - -(** Apply a type substitution to switch targets *) -and switch_targets_substitute (tsubst : T.TypeVarId.id -> T.ety) - (tgts : A.switch_targets) : A.switch_targets = - match tgts with - | A.If (st1, st2) -> - A.If (statement_substitute tsubst st1, statement_substitute tsubst st2) - | A.SwitchInt (int_ty, tgts, otherwise) -> - let tgts = - List.map (fun (sv, st) -> (sv, statement_substitute tsubst st)) tgts - in - let otherwise = statement_substitute tsubst otherwise in - A.SwitchInt (int_ty, tgts, otherwise) - -(** Apply a type substitution to a function body. Return the local variables - and the body. *) -let fun_body_substitute_in_body (tsubst : T.TypeVarId.id -> T.ety) - (body : A.fun_body) : A.var list * A.statement = - let rsubst r = r in - let locals = - List.map - (fun v -> { v with A.var_ty = ty_substitute rsubst tsubst v.A.var_ty }) - body.A.locals - in - let body = statement_substitute tsubst body.body in - (locals, body) - -(** Substitute a function signature *) -let substitute_signature (asubst : T.RegionGroupId.id -> V.AbstractionId.id) - (rsubst : T.RegionVarId.id -> T.RegionId.id) - (tsubst : T.TypeVarId.id -> T.rty) (sg : A.fun_sig) : A.inst_fun_sig = - let rsubst' (r : T.RegionVarId.id T.region) : T.RegionId.id T.region = - match r with T.Static -> T.Static | T.Var rid -> T.Var (rsubst rid) - in - let inputs = List.map (ty_substitute rsubst' tsubst) sg.A.inputs in - let output = ty_substitute rsubst' tsubst sg.A.output in - let subst_region_group (rg : T.region_var_group) : A.abs_region_group = - let id = asubst rg.id in - let regions = List.map rsubst rg.regions in - let parents = List.map asubst rg.parents in - { id; regions; parents } - in - let regions_hierarchy = List.map subst_region_group sg.A.regions_hierarchy in - { A.regions_hierarchy; inputs; output } diff --git a/src/SymbolicAst.ml b/src/SymbolicAst.ml deleted file mode 100644 index 604a7948..00000000 --- a/src/SymbolicAst.ml +++ /dev/null @@ -1,98 +0,0 @@ -(** The "symbolic" AST is the AST directly generated by the symbolic execution. - It is very rough and meant to be extremely straightforward to build during - the symbolic execution: we later apply transformations to generate the - pure AST that we export. *) - -module T = Types -module V = Values -module E = Expressions -module A = LlbcAst - -(** "Meta"-place: a place stored as meta-data. - - Whenever we need to introduce new symbolic variables, for instance because - of symbolic expansions, we try to store a "place", which gives information - about the origin of the values (this place information comes from assignment - information, etc.). - We later use this place information to generate meaningful name, to prettify - the generated code. - *) -type mplace = { - bv : Contexts.binder; - (** It is important that we store the binder, and not just the variable id, - because the most important information in a place is the name of the - variable! - *) - projection : E.projection; - (** We store the projection because we can, but it is actually not that useful *) -} - -type call_id = - | Fun of A.fun_id * V.FunCallId.id - (** A "regular" function (i.e., a function which is not a primitive operation) *) - | Unop of E.unop - | Binop of E.binop -[@@deriving show, ord] - -type call = { - call_id : call_id; - abstractions : V.AbstractionId.id list; - type_params : T.ety list; - args : V.typed_value list; - args_places : mplace option list; (** Meta information *) - dest : V.symbolic_value; - dest_place : mplace option; (** Meta information *) -} - -(** Meta information, not necessary for synthesis but useful to guide it to - generate a pretty output. - *) - -type meta = - | Assignment of mplace * V.typed_value * mplace option - (** We generated an assignment (destination, assigned value, src) *) - -(** **Rk.:** here, {!expression} is not at all equivalent to the expressions - used in LLBC: they are a first step towards lambda-calculus expressions. - *) -type expression = - | Return of V.typed_value option - (** There are two cases: - - the AST is for a forward function: the typed value should contain - the value which was in the return variable - - the AST is for a backward function: the typed value should be [None] - *) - | Panic - | FunCall of call * expression - | EndAbstraction of V.abs * expression - | EvalGlobal of A.GlobalDeclId.id * V.symbolic_value * expression - (** Evaluate a global to a fresh symbolic value *) - | Expansion of mplace option * V.symbolic_value * expansion - (** Expansion of a symbolic value. - - The place is "meta": it gives the path to the symbolic value (if available) - which got expanded (this path is available when the symbolic expansion - comes from a path evaluation, during an assignment for instance). - We use it to compute meaningful names for the variables we introduce, - to prettify the generated code. - *) - | Meta of meta * expression (** Meta information *) - -and expansion = - | ExpandNoBranch of V.symbolic_expansion * expression - (** A symbolic expansion which doesn't generate a branching. - Includes: - - concrete expansion - - borrow expansion - *Doesn't* include: - - expansion of ADTs with one variant - *) - | ExpandAdt of - (T.VariantId.id option * V.symbolic_value list * expression) list - (** ADT expansion *) - | ExpandBool of expression * expression - (** A boolean expansion (i.e, an [if ... then ... else ...]) *) - | ExpandInt of - T.integer_type * (V.scalar_value * expression) list * expression - (** An integer expansion (i.e, a switch over an integer). The last - expression is for the "otherwise" branch. *) diff --git a/src/SymbolicToPure.ml b/src/SymbolicToPure.ml deleted file mode 100644 index de4fb4c1..00000000 --- a/src/SymbolicToPure.ml +++ /dev/null @@ -1,1824 +0,0 @@ -open Errors -open LlbcAstUtils -open Pure -open PureUtils -module Id = Identifiers -module S = SymbolicAst -module TA = TypesAnalysis -module L = Logging -module PP = PrintPure -module FA = FunsAnalysis - -(** The local logger *) -let log = L.symbolic_to_pure_log - -type config = { - filter_useless_back_calls : bool; - (** If [true], filter the useless calls to backward functions. - - The useless calls are calls to backward functions which have no outputs. - This case happens if the original Rust function only takes *shared* borrows - as inputs, and is thus pretty common. - - We are allowed to do this only because in this specific case, - the backward function fails *exactly* when the forward function fails - (they actually do exactly the same thing, the only difference being - that the forward function can potentially return a value), and upon - reaching the place where we should introduce a call to the backward - function, we know we have introduced a call to the forward function. - - Also note that in general, backward functions "do more things" than - forward functions, and have more opportunities to fail (even though - in the generated code, backward functions should fail exactly when - the forward functions fail). - - We might want to move this optimization to the micro-passes subsequent - to the translation from symbolic to pure, but it is really super easy - to do it when going from symbolic to pure. - Note that we later filter the useless *forward* calls in the micro-passes, - where it is more natural to do. - *) -} - -type type_context = { - llbc_type_decls : T.type_decl TypeDeclId.Map.t; - type_decls : type_decl TypeDeclId.Map.t; - (** We use this for type-checking (for sanity checks) when translating - values and functions. - This map is empty when we translate the types, then contains all - the translated types when we translate the functions. - *) - types_infos : TA.type_infos; (* TODO: rename to type_infos *) -} - -type fun_sig_named_outputs = { - sg : fun_sig; (** A function signature *) - output_names : string option list; - (** In case the signature is for a backward function, we may provides names - for the outputs. The reason is that the outputs of backward functions - come from (in case there are no nested borrows) borrows present in the - inputs of the original rust function. In this situation, we can use the - names of those inputs to name the outputs. Those names are very useful - to generate beautiful codes (we may need to introduce temporary variables - in the bodies of the backward functions to store the returned values, in - which case we use those names). - *) -} - -type fun_context = { - llbc_fun_decls : A.fun_decl A.FunDeclId.Map.t; - fun_sigs : fun_sig_named_outputs RegularFunIdMap.t; (** *) - fun_infos : FA.fun_info A.FunDeclId.Map.t; -} - -type global_context = { llbc_global_decls : A.global_decl A.GlobalDeclId.Map.t } - -(** Whenever we translate a function call or an ended abstraction, we - store the related information (this is useful when translating ended - children abstractions). - *) -type call_info = { - forward : S.call; - forward_inputs : texpression list; - (** Remember the list of inputs given to the forward function. - - Those inputs include the state input, if pertinent (in which case - it is the last input). - *) - backwards : (V.abs * texpression list) T.RegionGroupId.Map.t; - (** A map from region group id (i.e., backward function id) to - pairs (abstraction, additional arguments received by the backward function) - - TODO: remove? it is also in the bs_ctx ("abstractions" field) - *) -} - -(** Body synthesis context *) -type bs_ctx = { - type_context : type_context; - fun_context : fun_context; - global_context : global_context; - fun_decl : A.fun_decl; - bid : T.RegionGroupId.id option; (** TODO: rename *) - sg : fun_sig; - (** The function signature - useful in particular to translate [Panic] *) - sv_to_var : var V.SymbolicValueId.Map.t; - (** Whenever we encounter a new symbolic value (introduced because of - a symbolic expansion or upon ending an abstraction, for instance) - we introduce a new variable (with a let-binding). - *) - var_counter : VarId.generator; - state_var : VarId.id; - (** The current state variable, in case we use a state *) - forward_inputs : var list; - (** The input parameters for the forward function *) - backward_inputs : var list T.RegionGroupId.Map.t; - (** The input parameters for the backward functions *) - backward_outputs : var list T.RegionGroupId.Map.t; - (** The variables that the backward functions will output *) - calls : call_info V.FunCallId.Map.t; - (** The function calls we encountered so far *) - abstractions : (V.abs * texpression list) V.AbstractionId.Map.t; - (** The ended abstractions we encountered so far, with their additional input arguments *) -} - -let type_check_pattern (ctx : bs_ctx) (v : typed_pattern) : unit = - let env = VarId.Map.empty in - let ctx = - { - PureTypeCheck.type_decls = ctx.type_context.type_decls; - global_decls = ctx.global_context.llbc_global_decls; - env; - } - in - let _ = PureTypeCheck.check_typed_pattern ctx v in - () - -let type_check_texpression (ctx : bs_ctx) (e : texpression) : unit = - let env = VarId.Map.empty in - let ctx = - { - PureTypeCheck.type_decls = ctx.type_context.type_decls; - global_decls = ctx.global_context.llbc_global_decls; - env; - } - in - PureTypeCheck.check_texpression ctx e - -(* TODO: move *) -let bs_ctx_to_ast_formatter (ctx : bs_ctx) : Print.LlbcAst.ast_formatter = - Print.LlbcAst.fun_decl_to_ast_formatter ctx.type_context.llbc_type_decls - ctx.fun_context.llbc_fun_decls ctx.global_context.llbc_global_decls - ctx.fun_decl - -let bs_ctx_to_pp_ast_formatter (ctx : bs_ctx) : PrintPure.ast_formatter = - let type_params = ctx.fun_decl.signature.type_params in - let type_decls = ctx.type_context.llbc_type_decls in - let fun_decls = ctx.fun_context.llbc_fun_decls in - let global_decls = ctx.global_context.llbc_global_decls in - PrintPure.mk_ast_formatter type_decls fun_decls global_decls type_params - -let ty_to_string (ctx : bs_ctx) (ty : ty) : string = - let fmt = bs_ctx_to_pp_ast_formatter ctx in - let fmt = PrintPure.ast_to_type_formatter fmt in - PrintPure.ty_to_string fmt ty - -let type_decl_to_string (ctx : bs_ctx) (def : type_decl) : string = - let type_params = def.type_params in - let type_decls = ctx.type_context.llbc_type_decls in - let fmt = PrintPure.mk_type_formatter type_decls type_params in - PrintPure.type_decl_to_string fmt def - -let texpression_to_string (ctx : bs_ctx) (e : texpression) : string = - let fmt = bs_ctx_to_pp_ast_formatter ctx in - PrintPure.texpression_to_string fmt false "" " " e - -let fun_sig_to_string (ctx : bs_ctx) (sg : fun_sig) : string = - let type_params = sg.type_params in - let type_decls = ctx.type_context.llbc_type_decls in - let fun_decls = ctx.fun_context.llbc_fun_decls in - let global_decls = ctx.global_context.llbc_global_decls in - let fmt = - PrintPure.mk_ast_formatter type_decls fun_decls global_decls type_params - in - PrintPure.fun_sig_to_string fmt sg - -let fun_decl_to_string (ctx : bs_ctx) (def : Pure.fun_decl) : string = - let type_params = def.signature.type_params in - let type_decls = ctx.type_context.llbc_type_decls in - let fun_decls = ctx.fun_context.llbc_fun_decls in - let global_decls = ctx.global_context.llbc_global_decls in - let fmt = - PrintPure.mk_ast_formatter type_decls fun_decls global_decls type_params - in - PrintPure.fun_decl_to_string fmt def - -(* TODO: move *) -let abs_to_string (ctx : bs_ctx) (abs : V.abs) : string = - let fmt = bs_ctx_to_ast_formatter ctx in - let fmt = Print.LlbcAst.ast_to_value_formatter fmt in - let indent = "" in - let indent_incr = " " in - Print.Values.abs_to_string fmt indent indent_incr abs - -let get_instantiated_fun_sig (fun_id : A.fun_id) - (back_id : T.RegionGroupId.id option) (tys : ty list) (ctx : bs_ctx) : - inst_fun_sig = - (* Lookup the non-instantiated function signature *) - let sg = - (RegularFunIdMap.find (fun_id, back_id) ctx.fun_context.fun_sigs).sg - in - (* Create the substitution *) - let tsubst = make_type_subst sg.type_params tys in - (* Apply *) - fun_sig_substitute tsubst sg - -let bs_ctx_lookup_llbc_type_decl (id : TypeDeclId.id) (ctx : bs_ctx) : - T.type_decl = - TypeDeclId.Map.find id ctx.type_context.llbc_type_decls - -let bs_ctx_lookup_llbc_fun_decl (id : A.FunDeclId.id) (ctx : bs_ctx) : - A.fun_decl = - A.FunDeclId.Map.find id ctx.fun_context.llbc_fun_decls - -(* TODO: move *) -let bs_ctx_lookup_local_function_sig (def_id : A.FunDeclId.id) - (back_id : T.RegionGroupId.id option) (ctx : bs_ctx) : fun_sig = - let id = (A.Regular def_id, back_id) in - (RegularFunIdMap.find id ctx.fun_context.fun_sigs).sg - -let bs_ctx_register_forward_call (call_id : V.FunCallId.id) (forward : S.call) - (args : texpression list) (ctx : bs_ctx) : bs_ctx = - let calls = ctx.calls in - assert (not (V.FunCallId.Map.mem call_id calls)); - let info = - { forward; forward_inputs = args; backwards = T.RegionGroupId.Map.empty } - in - let calls = V.FunCallId.Map.add call_id info calls in - { ctx with calls } - -(** [back_args]: the *additional* list of inputs received by the backward function *) -let bs_ctx_register_backward_call (abs : V.abs) (back_args : texpression list) - (ctx : bs_ctx) : bs_ctx * fun_id = - (* Insert the abstraction in the call informations *) - let back_id = abs.back_id in - let info = V.FunCallId.Map.find abs.call_id ctx.calls in - assert (not (T.RegionGroupId.Map.mem back_id info.backwards)); - let backwards = - T.RegionGroupId.Map.add back_id (abs, back_args) info.backwards - in - let info = { info with backwards } in - let calls = V.FunCallId.Map.add abs.call_id info ctx.calls in - (* Insert the abstraction in the abstractions map *) - let abstractions = ctx.abstractions in - assert (not (V.AbstractionId.Map.mem abs.abs_id abstractions)); - let abstractions = - V.AbstractionId.Map.add abs.abs_id (abs, back_args) abstractions - in - (* Retrieve the fun_id *) - let fun_id = - match info.forward.call_id with - | S.Fun (fid, _) -> Regular (fid, Some abs.back_id) - | S.Unop _ | S.Binop _ -> raise (Failure "Unreachable") - in - (* Update the context and return *) - ({ ctx with calls; abstractions }, fun_id) - -let rec translate_sty (ty : T.sty) : ty = - let translate = translate_sty in - match ty with - | T.Adt (type_id, regions, tys) -> ( - (* Can't translate types with regions for now *) - assert (regions = []); - let tys = List.map translate tys in - match type_id with - | T.AdtId adt_id -> Adt (AdtId adt_id, tys) - | T.Tuple -> mk_simpl_tuple_ty tys - | T.Assumed aty -> ( - match aty with - | T.Vec -> Adt (Assumed Vec, tys) - | T.Option -> Adt (Assumed Option, tys) - | T.Box -> ( - (* Eliminate the boxes *) - match tys with - | [ ty ] -> ty - | _ -> - failwith - "Box/vec/option type with incorrect number of arguments"))) - | TypeVar vid -> TypeVar vid - | Bool -> Bool - | Char -> Char - | Never -> raise (Failure "Unreachable") - | Integer int_ty -> Integer int_ty - | Str -> Str - | Array ty -> Array (translate ty) - | Slice ty -> Slice (translate ty) - | Ref (_, rty, _) -> translate rty - -let translate_field (f : T.field) : field = - let field_name = f.field_name in - let field_ty = translate_sty f.field_ty in - { field_name; field_ty } - -let translate_fields (fl : T.field list) : field list = - List.map translate_field fl - -let translate_variant (v : T.variant) : variant = - let variant_name = v.variant_name in - let fields = translate_fields v.fields in - { variant_name; fields } - -let translate_variants (vl : T.variant list) : variant list = - List.map translate_variant vl - -(** Translate a type def kind to IM *) -let translate_type_decl_kind (kind : T.type_decl_kind) : type_decl_kind = - match kind with - | T.Struct fields -> Struct (translate_fields fields) - | T.Enum variants -> Enum (translate_variants variants) - | T.Opaque -> Opaque - -(** Translate a type definition from IM - - TODO: this is not symbolic to pure but IM to pure. Still, I don't see the - point of moving this definition for now. - *) -let translate_type_decl (def : T.type_decl) : type_decl = - (* Translate *) - let def_id = def.T.def_id in - let name = def.name in - (* Can't translate types with regions for now *) - assert (def.region_params = []); - let type_params = def.type_params in - let kind = translate_type_decl_kind def.T.kind in - { def_id; name; type_params; kind } - -(** Translate a type, seen as an input/output of a forward function - (preserve all borrows, etc.) -*) - -let rec translate_fwd_ty (types_infos : TA.type_infos) (ty : 'r T.ty) : ty = - let translate = translate_fwd_ty types_infos in - match ty with - | T.Adt (type_id, regions, tys) -> ( - (* Can't translate types with regions for now *) - assert (regions = []); - (* Translate the type parameters *) - let t_tys = List.map translate tys in - (* Eliminate boxes and simplify tuples *) - match type_id with - | AdtId _ | T.Assumed (T.Vec | T.Option) -> - (* No general parametricity for now *) - assert (not (List.exists (TypesUtils.ty_has_borrows types_infos) tys)); - let type_id = - match type_id with - | AdtId adt_id -> AdtId adt_id - | T.Assumed T.Vec -> Assumed Vec - | T.Assumed T.Option -> Assumed Option - | _ -> raise (Failure "Unreachable") - in - Adt (type_id, t_tys) - | Tuple -> - (* Note that if there is exactly one type, [mk_simpl_tuple_ty] is the - identity *) - mk_simpl_tuple_ty t_tys - | T.Assumed T.Box -> ( - (* We eliminate boxes *) - (* No general parametricity for now *) - assert (not (List.exists (TypesUtils.ty_has_borrows types_infos) tys)); - match t_tys with - | [ bty ] -> bty - | _ -> - failwith - "Unreachable: box/vec/option receives exactly one type \ - parameter")) - | TypeVar vid -> TypeVar vid - | Bool -> Bool - | Char -> Char - | Never -> raise (Failure "Unreachable") - | Integer int_ty -> Integer int_ty - | Str -> Str - | Array ty -> - assert (not (TypesUtils.ty_has_borrows types_infos ty)); - Array (translate ty) - | Slice ty -> - assert (not (TypesUtils.ty_has_borrows types_infos ty)); - Slice (translate ty) - | Ref (_, rty, _) -> translate rty - -(** Simply calls [translate_fwd_ty] *) -let ctx_translate_fwd_ty (ctx : bs_ctx) (ty : 'r T.ty) : ty = - let types_infos = ctx.type_context.types_infos in - translate_fwd_ty types_infos ty - -(** Translate a type, when some regions may have ended. - - We return an option, because the translated type may be empty. - - [inside_mut]: are we inside a mutable borrow? - *) -let rec translate_back_ty (types_infos : TA.type_infos) - (keep_region : 'r -> bool) (inside_mut : bool) (ty : 'r T.ty) : ty option = - let translate = translate_back_ty types_infos keep_region inside_mut in - (* A small helper for "leave" types *) - let wrap ty = if inside_mut then Some ty else None in - match ty with - | T.Adt (type_id, _, tys) -> ( - match type_id with - | T.AdtId _ | Assumed (T.Vec | T.Option) -> - (* Don't accept ADTs (which are not tuples) with borrows for now *) - assert (not (TypesUtils.ty_has_borrows types_infos ty)); - let type_id = - match type_id with - | T.AdtId id -> AdtId id - | T.Assumed T.Vec -> Assumed Vec - | T.Assumed T.Option -> Assumed Option - | T.Tuple | T.Assumed T.Box -> raise (Failure "Unreachable") - in - if inside_mut then - let tys_t = List.filter_map translate tys in - Some (Adt (type_id, tys_t)) - else None - | Assumed T.Box -> ( - (* Don't accept ADTs (which are not tuples) with borrows for now *) - assert (not (TypesUtils.ty_has_borrows types_infos ty)); - (* Eliminate the box *) - match tys with - | [ bty ] -> translate bty - | _ -> - failwith "Unreachable: boxes receive exactly one type parameter") - | T.Tuple -> ( - (* Tuples can contain borrows (which we eliminated) *) - let tys_t = List.filter_map translate tys in - match tys_t with - | [] -> None - | _ -> - (* Note that if there is exactly one type, [mk_simpl_tuple_ty] - * is the identity *) - Some (mk_simpl_tuple_ty tys_t))) - | TypeVar vid -> wrap (TypeVar vid) - | Bool -> wrap Bool - | Char -> wrap Char - | Never -> raise (Failure "Unreachable") - | Integer int_ty -> wrap (Integer int_ty) - | Str -> wrap Str - | Array ty -> ( - assert (not (TypesUtils.ty_has_borrows types_infos ty)); - match translate ty with None -> None | Some ty -> Some (Array ty)) - | Slice ty -> ( - assert (not (TypesUtils.ty_has_borrows types_infos ty)); - match translate ty with None -> None | Some ty -> Some (Slice ty)) - | Ref (r, rty, rkind) -> ( - match rkind with - | T.Shared -> - (* Ignore shared references, unless we are below a mutable borrow *) - if inside_mut then translate rty else None - | T.Mut -> - (* Dive in, remembering the fact that we are inside a mutable borrow *) - let inside_mut = true in - if keep_region r then - translate_back_ty types_infos keep_region inside_mut rty - else None) - -(** Simply calls [translate_back_ty] *) -let ctx_translate_back_ty (ctx : bs_ctx) (keep_region : 'r -> bool) - (inside_mut : bool) (ty : 'r T.ty) : ty option = - let types_infos = ctx.type_context.types_infos in - translate_back_ty types_infos keep_region inside_mut ty - -(** List the ancestors of an abstraction *) -let list_ancestor_abstractions_ids (ctx : bs_ctx) (abs : V.abs) : - V.AbstractionId.id list = - (* We could do something more "elegant" without references, but it is - * so much simpler to use references... *) - let abs_set = ref V.AbstractionId.Set.empty in - let rec gather (abs_id : V.AbstractionId.id) : unit = - if V.AbstractionId.Set.mem abs_id !abs_set then () - else ( - abs_set := V.AbstractionId.Set.add abs_id !abs_set; - let abs, _ = V.AbstractionId.Map.find abs_id ctx.abstractions in - List.iter gather abs.original_parents) - in - List.iter gather abs.original_parents; - let ids = !abs_set in - (* List the ancestors, in the proper order *) - let call_info = V.FunCallId.Map.find abs.call_id ctx.calls in - List.filter - (fun id -> V.AbstractionId.Set.mem id ids) - call_info.forward.abstractions - -let list_ancestor_abstractions (ctx : bs_ctx) (abs : V.abs) : - (V.abs * texpression list) list = - let abs_ids = list_ancestor_abstractions_ids ctx abs in - List.map (fun id -> V.AbstractionId.Map.find id ctx.abstractions) abs_ids - -(** Small utility. *) -let get_fun_effect_info (fun_infos : FA.fun_info A.FunDeclId.Map.t) - (fun_id : A.fun_id) (gid : T.RegionGroupId.id option) : fun_effect_info = - match fun_id with - | A.Regular fid -> - let info = A.FunDeclId.Map.find fid fun_infos in - let input_state = info.stateful in - let output_state = input_state && gid = None in - { can_fail = info.can_fail; input_state; output_state } - | A.Assumed aid -> - { - can_fail = Assumed.assumed_can_fail aid; - input_state = false; - output_state = false; - } - -(** Translate a function signature. - - Note that the function also takes a list of names for the inputs, and - computes, for every output for the backward functions, a corresponding - name (outputs for backward functions come from borrows in the inputs - of the forward function). - *) -let translate_fun_sig (fun_infos : FA.fun_info A.FunDeclId.Map.t) - (fun_id : A.fun_id) (types_infos : TA.type_infos) (sg : A.fun_sig) - (input_names : string option list) (bid : T.RegionGroupId.id option) : - fun_sig_named_outputs = - (* Retrieve the list of parent backward functions *) - let gid, parents = - match bid with - | None -> (None, T.RegionGroupId.Set.empty) - | Some bid -> - let parents = list_parent_region_groups sg bid in - (Some bid, parents) - in - (* List the inputs for: - * - the forward function - * - the parent backward functions, in proper order - * - the current backward function (if it is a backward function) - *) - let fwd_inputs = List.map (translate_fwd_ty types_infos) sg.inputs in - (* For the backward functions: for now we don't supported nested borrows, - * so just check that there aren't parent regions *) - assert (T.RegionGroupId.Set.is_empty parents); - (* Small helper to translate types for backward functions *) - let translate_back_ty_for_gid (gid : T.RegionGroupId.id) : T.sty -> ty option - = - let rg = T.RegionGroupId.nth sg.regions_hierarchy gid in - let regions = T.RegionVarId.Set.of_list rg.regions in - let keep_region r = - match r with - | T.Static -> raise Unimplemented - | T.Var r -> T.RegionVarId.Set.mem r regions - in - let inside_mut = false in - translate_back_ty types_infos keep_region inside_mut - in - (* Compute the additinal inputs for the current function, if it is a backward - * function *) - let back_inputs = - match gid with - | None -> [] - | Some gid -> - (* For now, we don't allow nested borrows, so the additional inputs to the - backward function can only come from borrows that were returned like - in (for the backward function we introduce for 'a): - {[ - fn f<'a>(...) -> &'a mut u32; - ]} - Upon ending the abstraction for 'a, we need to get back the borrow - the function returned. - *) - List.filter_map (translate_back_ty_for_gid gid) [ sg.output ] - in - (* Does the function take a state as input, does it return a state and can - * it fail? *) - let effect_info = get_fun_effect_info fun_infos fun_id bid in - (* *) - let state_ty = if effect_info.input_state then [ mk_state_ty ] else [] in - (* Concatenate the inputs, in the following order: - * - forward inputs - * - state input - * - backward inputs - *) - let inputs = List.concat [ fwd_inputs; state_ty; back_inputs ] in - (* Outputs *) - let output_names, doutputs = - match gid with - | None -> - (* This is a forward function: there is one (unnamed) output *) - ([ None ], [ translate_fwd_ty types_infos sg.output ]) - | Some gid -> - (* This is a backward function: there might be several outputs. - The outputs are the borrows inside the regions of the abstractions - and which are present in the input values. For instance, see: - {[ - fn f<'a>(x : &'a mut u32) -> ...; - ]} - Upon ending the abstraction for 'a, we give back the borrow which - was consumed through the [x] parameter. - *) - let outputs = - List.map - (fun (name, input_ty) -> - (name, translate_back_ty_for_gid gid input_ty)) - (List.combine input_names sg.inputs) - in - (* Filter *) - let outputs = - List.filter (fun (_, opt_ty) -> Option.is_some opt_ty) outputs - in - let outputs = - List.map (fun (name, opt_ty) -> (name, Option.get opt_ty)) outputs - in - List.split outputs - in - (* Create the return type *) - let output = - (* Group the outputs together *) - let output = mk_simpl_tuple_ty doutputs in - (* Add the output state *) - let output = - if effect_info.output_state then mk_simpl_tuple_ty [ mk_state_ty; output ] - else output - in - (* Wrap in a result type *) - if effect_info.can_fail then mk_result_ty output else output - in - (* Type parameters *) - let type_params = sg.type_params in - (* Return *) - let info = - { - num_fwd_inputs = List.length fwd_inputs; - num_back_inputs = - (if bid = None then None else Some (List.length back_inputs)); - effect_info; - } - in - let sg = { type_params; inputs; output; doutputs; info } in - { sg; output_names } - -let bs_ctx_fresh_state_var (ctx : bs_ctx) : bs_ctx * typed_pattern = - (* Generate the fresh variable *) - let id, var_counter = VarId.fresh ctx.var_counter in - let var = - { id; basename = Some ConstStrings.state_basename; ty = mk_state_ty } - in - let state_var = mk_typed_pattern_from_var var None in - (* Update the context *) - let ctx = { ctx with var_counter; state_var = id } in - (* Return *) - (ctx, state_var) - -let fresh_named_var_for_symbolic_value (basename : string option) - (sv : V.symbolic_value) (ctx : bs_ctx) : bs_ctx * var = - (* Generate the fresh variable *) - let id, var_counter = VarId.fresh ctx.var_counter in - let ty = ctx_translate_fwd_ty ctx sv.sv_ty in - let var = { id; basename; ty } in - (* Insert in the map *) - let sv_to_var = V.SymbolicValueId.Map.add sv.sv_id var ctx.sv_to_var in - (* Update the context *) - let ctx = { ctx with var_counter; sv_to_var } in - (* Return *) - (ctx, var) - -let fresh_var_for_symbolic_value (sv : V.symbolic_value) (ctx : bs_ctx) : - bs_ctx * var = - fresh_named_var_for_symbolic_value None sv ctx - -let fresh_vars_for_symbolic_values (svl : V.symbolic_value list) (ctx : bs_ctx) - : bs_ctx * var list = - List.fold_left_map (fun ctx sv -> fresh_var_for_symbolic_value sv ctx) ctx svl - -let fresh_named_vars_for_symbolic_values - (svl : (string option * V.symbolic_value) list) (ctx : bs_ctx) : - bs_ctx * var list = - List.fold_left_map - (fun ctx (name, sv) -> fresh_named_var_for_symbolic_value name sv ctx) - ctx svl - -(** This generates a fresh variable **which is not to be linked to any symbolic value** *) -let fresh_var (basename : string option) (ty : ty) (ctx : bs_ctx) : bs_ctx * var - = - (* Generate the fresh variable *) - let id, var_counter = VarId.fresh ctx.var_counter in - let var = { id; basename; ty } in - (* Update the context *) - let ctx = { ctx with var_counter } in - (* Return *) - (ctx, var) - -let fresh_vars (vars : (string option * ty) list) (ctx : bs_ctx) : - bs_ctx * var list = - List.fold_left_map (fun ctx (name, ty) -> fresh_var name ty ctx) ctx vars - -let lookup_var_for_symbolic_value (sv : V.symbolic_value) (ctx : bs_ctx) : var = - V.SymbolicValueId.Map.find sv.sv_id ctx.sv_to_var - -(** Peel boxes as long as the value is of the form [Box] *) -let rec unbox_typed_value (v : V.typed_value) : V.typed_value = - match (v.value, v.ty) with - | V.Adt av, T.Adt (T.Assumed T.Box, _, _) -> ( - match av.field_values with - | [ bv ] -> unbox_typed_value bv - | _ -> raise (Failure "Unreachable")) - | _ -> v - -(** Translate a typed value. - - It is used, for instance, on values used as inputs for function calls. - - **IMPORTANT**: this function makes the assumption that the typed value - doesn't contain ⊥. This means in particular that symbolic values don't - contain ended regions. - - TODO: we might want to remember in the symbolic AST the set of ended - regions, at the points where we need it, for sanity checks (though the - sanity checks in the symbolic interpreter should be enough). - The points where we need this set so far: - - function call - - end abstraction - - return - *) -let rec typed_value_to_texpression (ctx : bs_ctx) (v : V.typed_value) : - texpression = - (* We need to ignore boxes *) - let v = unbox_typed_value v in - let translate = typed_value_to_texpression ctx in - (* Translate the type *) - let ty = ctx_translate_fwd_ty ctx v.ty in - (* Translate the value *) - let value = - match v.value with - | V.Concrete cv -> { e = Const cv; ty } - | Adt av -> ( - let variant_id = av.variant_id in - let field_values = List.map translate av.field_values in - (* Eliminate the tuple wrapper if it is a tuple with exactly one field *) - match v.ty with - | T.Adt (T.Tuple, _, _) -> - assert (variant_id = None); - mk_simpl_tuple_texpression field_values - | _ -> - (* Retrieve the type and the translated type arguments from the - * translated type (simpler this way) *) - let adt_id, type_args = - match ty with - | Adt (type_id, tys) -> (type_id, tys) - | _ -> raise (Failure "Unreachable") - in - (* Create the constructor *) - let qualif_id = AdtCons { adt_id; variant_id = av.variant_id } in - let qualif = { id = qualif_id; type_args } in - let cons_e = Qualif qualif in - let field_tys = - List.map (fun (v : texpression) -> v.ty) field_values - in - let cons_ty = mk_arrows field_tys ty in - let cons = { e = cons_e; ty = cons_ty } in - (* Apply the constructor *) - mk_apps cons field_values) - | Bottom -> raise (Failure "Unreachable") - | Loan lc -> ( - match lc with - | SharedLoan (_, v) -> translate v - | MutLoan _ -> raise (Failure "Unreachable")) - | Borrow bc -> ( - match bc with - | V.SharedBorrow (mv, _) -> - (* The meta-value stored in the shared borrow was added especially - * for this case (because we can't use the borrow id for lookups) *) - translate mv - | V.InactivatedMutBorrow (mv, _) -> - (* Same as for shared borrows. However, note that we use inactivated borrows - * only in meta-data: a value actually *used in the translation* can't come - * from an unpromoted inactivated borrow *) - translate mv - | V.MutBorrow (_, v) -> - (* Borrows are the identity in the extraction *) - translate v) - | Symbolic sv -> - let var = lookup_var_for_symbolic_value sv ctx in - mk_texpression_from_var var - in - (* Debugging *) - log#ldebug - (lazy - ("typed_value_to_texpression: result:" ^ "\n- input value:\n" - ^ V.show_typed_value v ^ "\n- translated expression:\n" - ^ show_texpression value)); - (* Sanity check *) - type_check_texpression ctx value; - (* Return *) - value - -(** Explore an abstraction value and convert it to a consumed value - by collecting all the meta-values from the ended *loans*. - - Consumed values are rvalues, because when an abstraction ends, we - introduce a call to a backward function in the synthesized program, - which takes as inputs those consumed values: - {[ - // Rust: - fn choose<'a>(b: bool, x : &'a mut u32, y : &'a mut u32) -> &'a mut u32; - - // Synthesis: - let ... = choose_back b x y nz in - ^^ - ]} - *) -let rec typed_avalue_to_consumed (ctx : bs_ctx) (av : V.typed_avalue) : - texpression option = - let translate = typed_avalue_to_consumed ctx in - let value = - match av.value with - | AConcrete _ -> raise (Failure "Unreachable") - | AAdt adt_v -> ( - (* Translate the field values *) - let field_values = List.filter_map translate adt_v.field_values in - (* For now, only tuples can contain borrows *) - let adt_id, _, _ = TypesUtils.ty_as_adt av.ty in - match adt_id with - | T.AdtId _ | T.Assumed (T.Box | T.Vec | T.Option) -> - assert (field_values = []); - None - | T.Tuple -> - (* Return *) - if field_values = [] then None - else - (* Note that if there is exactly one field value, - * [mk_simpl_tuple_rvalue] is the identity *) - let rv = mk_simpl_tuple_texpression field_values in - Some rv) - | ABottom -> raise (Failure "Unreachable") - | ALoan lc -> aloan_content_to_consumed ctx lc - | ABorrow bc -> aborrow_content_to_consumed ctx bc - | ASymbolic aproj -> aproj_to_consumed ctx aproj - | AIgnored -> None - in - (* Sanity check - Rk.: we do this at every recursive call, which is a bit - * expansive... *) - (match value with - | None -> () - | Some value -> type_check_texpression ctx value); - (* Return *) - value - -and aloan_content_to_consumed (ctx : bs_ctx) (lc : V.aloan_content) : - texpression option = - match lc with - | AMutLoan (_, _) | ASharedLoan (_, _, _) -> raise (Failure "Unreachable") - | AEndedMutLoan { child = _; given_back = _; given_back_meta } -> - (* Return the meta-value *) - Some (typed_value_to_texpression ctx given_back_meta) - | AEndedSharedLoan (_, _) -> - (* We don't dive into shared loans: there is nothing to give back - * inside (note that there could be a mutable borrow in the shared - * value, pointing to a mutable loan in the child avalue, but this - * borrow is in practice immutable) *) - None - | AIgnoredMutLoan (_, _) -> - (* There can be *inner* not ended mutable loans, but not outer ones *) - raise (Failure "Unreachable") - | AEndedIgnoredMutLoan _ -> - (* This happens with nested borrows: we need to dive in *) - raise Unimplemented - | AIgnoredSharedLoan _ -> - (* Ignore *) - None - -and aborrow_content_to_consumed (_ctx : bs_ctx) (bc : V.aborrow_content) : - texpression option = - match bc with - | V.AMutBorrow (_, _, _) | ASharedBorrow _ | AIgnoredMutBorrow (_, _) -> - raise (Failure "Unreachable") - | AEndedMutBorrow (_, _) -> - (* We collect consumed values: ignore *) - None - | AEndedIgnoredMutBorrow _ -> - (* This happens with nested borrows: we need to dive in *) - raise Unimplemented - | AEndedSharedBorrow | AProjSharedBorrow _ -> - (* Ignore *) - None - -and aproj_to_consumed (ctx : bs_ctx) (aproj : V.aproj) : texpression option = - match aproj with - | V.AEndedProjLoans (msv, []) -> - (* The symbolic value was left unchanged *) - let var = lookup_var_for_symbolic_value msv ctx in - Some (mk_texpression_from_var var) - | V.AEndedProjLoans (_, [ (mnv, child_aproj) ]) -> - assert (child_aproj = AIgnoredProjBorrows); - (* The symbolic value was updated *) - let var = lookup_var_for_symbolic_value mnv ctx in - Some (mk_texpression_from_var var) - | V.AEndedProjLoans (_, _) -> - (* The symbolic value was updated, and the given back values come from sevearl - * abstractions *) - raise Unimplemented - | AEndedProjBorrows _ -> (* We consider consumed values *) None - | AIgnoredProjBorrows | AProjLoans (_, _) | AProjBorrows (_, _) -> - raise (Failure "Unreachable") - -(** Convert the abstraction values in an abstraction to consumed values. - - See [typed_avalue_to_consumed]. - *) -let abs_to_consumed (ctx : bs_ctx) (abs : V.abs) : texpression list = - log#ldebug (lazy ("abs_to_consumed:\n" ^ abs_to_string ctx abs)); - List.filter_map (typed_avalue_to_consumed ctx) abs.avalues - -let translate_mprojection_elem (pe : E.projection_elem) : - mprojection_elem option = - match pe with - | Deref | DerefBox -> None - | Field (pkind, field_id) -> Some { pkind; field_id } - -let translate_mprojection (p : E.projection) : mprojection = - List.filter_map translate_mprojection_elem p - -(** Translate a "meta"-place *) -let translate_mplace (p : S.mplace) : mplace = - let var_id = p.bv.index in - let name = p.bv.name in - let projection = translate_mprojection p.projection in - { var_id; name; projection } - -let translate_opt_mplace (p : S.mplace option) : mplace option = - match p with None -> None | Some p -> Some (translate_mplace p) - -(** Explore an abstraction value and convert it to a given back value - by collecting all the meta-values from the ended *borrows*. - - Given back values are patterns, because when an abstraction ends, we - introduce a call to a backward function in the synthesized program, - which introduces new values: - {[ - let (nx, ny) = f_back ... in - ^^^^^^^^ - ]} - - [mp]: it is possible to provide some meta-place information, to guide - the heuristics which later find pretty names for the variables. - *) -let rec typed_avalue_to_given_back (mp : mplace option) (av : V.typed_avalue) - (ctx : bs_ctx) : bs_ctx * typed_pattern option = - let ctx, value = - match av.value with - | AConcrete _ -> raise (Failure "Unreachable") - | AAdt adt_v -> ( - (* Translate the field values *) - (* For now we forget the meta-place information so that it doesn't get used - * by several fields (which would then all have the same name...), but we - * might want to do something smarter *) - let mp = None in - let ctx, field_values = - List.fold_left_map - (fun ctx fv -> typed_avalue_to_given_back mp fv ctx) - ctx adt_v.field_values - in - let field_values = List.filter_map (fun x -> x) field_values in - (* For now, only tuples can contain borrows - note that if we gave - * something like a [&mut Vec] to a function, we give give back the - * vector value upon visiting the "abstraction borrow" node *) - let adt_id, _, _ = TypesUtils.ty_as_adt av.ty in - match adt_id with - | T.AdtId _ | T.Assumed (T.Box | T.Vec | T.Option) -> - assert (field_values = []); - (ctx, None) - | T.Tuple -> - (* Return *) - let variant_id = adt_v.variant_id in - assert (variant_id = None); - if field_values = [] then (ctx, None) - else - (* Note that if there is exactly one field value, [mk_simpl_tuple_pattern] - * is the identity *) - let lv = mk_simpl_tuple_pattern field_values in - (ctx, Some lv)) - | ABottom -> raise (Failure "Unreachable") - | ALoan lc -> aloan_content_to_given_back mp lc ctx - | ABorrow bc -> aborrow_content_to_given_back mp bc ctx - | ASymbolic aproj -> aproj_to_given_back mp aproj ctx - | AIgnored -> (ctx, None) - in - (* Sanity check - Rk.: we do this at every recursive call, which is a bit - * expansive... *) - (match value with None -> () | Some value -> type_check_pattern ctx value); - (* Return *) - (ctx, value) - -and aloan_content_to_given_back (_mp : mplace option) (lc : V.aloan_content) - (ctx : bs_ctx) : bs_ctx * typed_pattern option = - match lc with - | AMutLoan (_, _) | ASharedLoan (_, _, _) -> raise (Failure "Unreachable") - | AEndedMutLoan { child = _; given_back = _; given_back_meta = _ } - | AEndedSharedLoan (_, _) -> - (* We consider given back values, and thus ignore those *) - (ctx, None) - | AIgnoredMutLoan (_, _) -> - (* There can be *inner* not ended mutable loans, but not outer ones *) - raise (Failure "Unreachable") - | AEndedIgnoredMutLoan _ -> - (* This happens with nested borrows: we need to dive in *) - raise Unimplemented - | AIgnoredSharedLoan _ -> - (* Ignore *) - (ctx, None) - -and aborrow_content_to_given_back (mp : mplace option) (bc : V.aborrow_content) - (ctx : bs_ctx) : bs_ctx * typed_pattern option = - match bc with - | V.AMutBorrow (_, _, _) | ASharedBorrow _ | AIgnoredMutBorrow (_, _) -> - raise (Failure "Unreachable") - | AEndedMutBorrow (msv, _) -> - (* Return the meta-symbolic-value *) - let ctx, var = fresh_var_for_symbolic_value msv ctx in - (ctx, Some (mk_typed_pattern_from_var var mp)) - | AEndedIgnoredMutBorrow _ -> - (* This happens with nested borrows: we need to dive in *) - raise Unimplemented - | AEndedSharedBorrow | AProjSharedBorrow _ -> - (* Ignore *) - (ctx, None) - -and aproj_to_given_back (mp : mplace option) (aproj : V.aproj) (ctx : bs_ctx) : - bs_ctx * typed_pattern option = - match aproj with - | V.AEndedProjLoans (_, child_projs) -> - (* There may be children borrow projections in case of nested borrows, - * in which case we need to dive in - we disallow nested borrows for now *) - assert ( - List.for_all - (fun (_, aproj) -> aproj = V.AIgnoredProjBorrows) - child_projs); - (ctx, None) - | AEndedProjBorrows mv -> - (* Return the meta-value *) - let ctx, var = fresh_var_for_symbolic_value mv ctx in - (ctx, Some (mk_typed_pattern_from_var var mp)) - | AIgnoredProjBorrows | AProjLoans (_, _) | AProjBorrows (_, _) -> - raise (Failure "Unreachable") - -(** Convert the abstraction values in an abstraction to given back values. - - See [typed_avalue_to_given_back]. - *) -let abs_to_given_back (mpl : mplace option list) (abs : V.abs) (ctx : bs_ctx) : - bs_ctx * typed_pattern list = - let avalues = List.combine mpl abs.avalues in - let ctx, values = - List.fold_left_map - (fun ctx (mp, av) -> typed_avalue_to_given_back mp av ctx) - ctx avalues - in - let values = List.filter_map (fun x -> x) values in - (ctx, values) - -(** Simply calls [abs_to_given_back] *) -let abs_to_given_back_no_mp (abs : V.abs) (ctx : bs_ctx) : - bs_ctx * typed_pattern list = - let mpl = List.map (fun _ -> None) abs.avalues in - abs_to_given_back mpl abs ctx - -(** Return the ordered list of the (transitive) parents of a given abstraction. - - Is used for instance when collecting the input values given to all the - parent functions, in order to properly instantiate an - *) -let get_abs_ancestors (ctx : bs_ctx) (abs : V.abs) : - S.call * (V.abs * texpression list) list = - let call_info = V.FunCallId.Map.find abs.call_id ctx.calls in - let abs_ancestors = list_ancestor_abstractions ctx abs in - (call_info.forward, abs_ancestors) - -let rec translate_expression (config : config) (e : S.expression) (ctx : bs_ctx) - : texpression = - match e with - | S.Return opt_v -> translate_return opt_v ctx - | Panic -> translate_panic ctx - | FunCall (call, e) -> translate_function_call config call e ctx - | EndAbstraction (abs, e) -> translate_end_abstraction config abs e ctx - | EvalGlobal (gid, sv, e) -> translate_global_eval config gid sv e ctx - | Expansion (p, sv, exp) -> translate_expansion config p sv exp ctx - | Meta (meta, e) -> translate_meta config meta e ctx - -and translate_panic (ctx : bs_ctx) : texpression = - (* Here we use the function return type - note that it is ok because - * we don't match on panics which happen inside the function body - - * but it won't be true anymore once we translate individual blocks *) - (* If we use a state monad, we need to add a lambda for the state variable *) - (* Note that only forward functions return a state *) - let output_ty = mk_simpl_tuple_ty ctx.sg.doutputs in - if ctx.sg.info.effect_info.output_state then - (* Create the [Fail] value *) - let ret_ty = mk_simpl_tuple_ty [ mk_state_ty; output_ty ] in - let ret_v = mk_result_fail_texpression ret_ty in - ret_v - else mk_result_fail_texpression output_ty - -and translate_return (opt_v : V.typed_value option) (ctx : bs_ctx) : texpression - = - (* There are two cases: - - either we are translating a forward function, in which case the optional - value should be [Some] (it is the returned value) - - or we are translating a backward function, in which case it should be [None] - *) - match ctx.bid with - | None -> - (* Forward function *) - let v = Option.get opt_v in - let v = typed_value_to_texpression ctx v in - (* We may need to return a state - * - error-monad: Return x - * - state-error: Return (state, x) - * *) - if ctx.sg.info.effect_info.output_state then - let state_var = - { - id = ctx.state_var; - basename = Some ConstStrings.state_basename; - ty = mk_state_ty; - } - in - let state_rvalue = mk_texpression_from_var state_var in - mk_result_return_texpression - (mk_simpl_tuple_texpression [ state_rvalue; v ]) - else mk_result_return_texpression v - | Some bid -> - (* Backward function *) - (* Sanity check *) - assert (opt_v = None); - assert (not ctx.sg.info.effect_info.output_state); - (* We simply need to return the variables in which we stored the values - * we need to give back. - * See the explanations for the [SynthInput] case in [translate_end_abstraction] *) - let backward_outputs = - T.RegionGroupId.Map.find bid ctx.backward_outputs - in - let field_values = List.map mk_texpression_from_var backward_outputs in - (* Backward functions never return a state *) - (* TODO: we should use a [fail] function, it would be cleaner *) - let ret_value = mk_simpl_tuple_texpression field_values in - let ret_value = mk_result_return_texpression ret_value in - ret_value - -and translate_function_call (config : config) (call : S.call) (e : S.expression) - (ctx : bs_ctx) : texpression = - (* Translate the function call *) - let type_args = List.map (ctx_translate_fwd_ty ctx) call.type_params in - let args = - let args = List.map (typed_value_to_texpression ctx) call.args in - let args_mplaces = List.map translate_opt_mplace call.args_places in - List.map - (fun (arg, mp) -> mk_opt_mplace_texpression mp arg) - (List.combine args args_mplaces) - in - let dest_mplace = translate_opt_mplace call.dest_place in - let ctx, dest = fresh_var_for_symbolic_value call.dest ctx in - (* Retrieve the function id, and register the function call in the context - * if necessary. *) - let ctx, fun_id, effect_info, args, out_state = - match call.call_id with - | S.Fun (fid, call_id) -> - (* Regular function call *) - let func = Regular (fid, None) in - (* Retrieve the effect information about this function (can fail, - * takes a state as input, etc.) *) - let effect_info = - get_fun_effect_info ctx.fun_context.fun_infos fid None - in - (* Add the state input argument *) - let args = - if effect_info.input_state then - let state_var = { e = Var ctx.state_var; ty = mk_state_ty } in - List.append args [ state_var ] - else args - in - (* Generate a fresh state variable if the function call introduces - * a new variable *) - let ctx, out_state = - if effect_info.input_state then - let ctx, var = bs_ctx_fresh_state_var ctx in - (ctx, Some var) - else (ctx, None) - in - (* Register the function call *) - let ctx = bs_ctx_register_forward_call call_id call args ctx in - (ctx, func, effect_info, args, out_state) - | S.Unop E.Not -> - let effect_info = - { can_fail = false; input_state = false; output_state = false } - in - (ctx, Unop Not, effect_info, args, None) - | S.Unop E.Neg -> ( - match args with - | [ arg ] -> - let int_ty = ty_as_integer arg.ty in - (* Note that negation can lead to an overflow and thus fail (it - * is thus monadic) *) - let effect_info = - { can_fail = true; input_state = false; output_state = false } - in - (ctx, Unop (Neg int_ty), effect_info, args, None) - | _ -> raise (Failure "Unreachable")) - | S.Unop (E.Cast (src_ty, tgt_ty)) -> - (* Note that cast can fail *) - let effect_info = - { can_fail = true; input_state = false; output_state = false } - in - (ctx, Unop (Cast (src_ty, tgt_ty)), effect_info, args, None) - | S.Binop binop -> ( - match args with - | [ arg0; arg1 ] -> - let int_ty0 = ty_as_integer arg0.ty in - let int_ty1 = ty_as_integer arg1.ty in - assert (int_ty0 = int_ty1); - let effect_info = - { - can_fail = ExpressionsUtils.binop_can_fail binop; - input_state = false; - output_state = false; - } - in - (ctx, Binop (binop, int_ty0), effect_info, args, None) - | _ -> raise (Failure "Unreachable")) - in - let dest_v = - let dest = mk_typed_pattern_from_var dest dest_mplace in - match out_state with - | None -> dest - | Some out_state -> mk_simpl_tuple_pattern [ out_state; dest ] - in - let func = { id = Func fun_id; type_args } in - let input_tys = (List.map (fun (x : texpression) -> x.ty)) args in - let ret_ty = - if effect_info.can_fail then mk_result_ty dest_v.ty else dest_v.ty - in - let func_ty = mk_arrows input_tys ret_ty in - let func = { e = Qualif func; ty = func_ty } in - let call = mk_apps func args in - (* Translate the next expression *) - let next_e = translate_expression config e ctx in - (* Put together *) - mk_let effect_info.can_fail dest_v call next_e - -and translate_end_abstraction (config : config) (abs : V.abs) (e : S.expression) - (ctx : bs_ctx) : texpression = - log#ldebug - (lazy - ("translate_end_abstraction: abstraction kind: " - ^ V.show_abs_kind abs.kind)); - match abs.kind with - | V.SynthInput -> - (* When we end an input abstraction, this input abstraction gets back - * the borrows which it introduced in the context through the input - * values: by listing those values, we get the values which are given - * back by one of the backward functions we are synthesizing. *) - (* Note that we don't support nested borrows for now: if we find - * an ended synthesized input abstraction, it must be the one corresponding - * to the backward function wer are synthesizing, it can't be the one - * for a parent backward function. - *) - let bid = Option.get ctx.bid in - assert (abs.back_id = bid); - - (* The translation is done as follows: - * - for a given backward function, we choose a set of variables [v_i] - * - when we detect the ended input abstraction which corresponds - * to the backward function, and which consumed the values [consumed_i], - * we introduce: - * {[ - * let v_i = consumed_i in - * ... - * ]} - * Then, when we reach the [Return] node, we introduce: - * {[ - * (v_i) - * ]} - * *) - (* First, get the given back variables *) - let given_back_variables = - T.RegionGroupId.Map.find bid ctx.backward_outputs - in - (* Get the list of values consumed by the abstraction upon ending *) - let consumed_values = abs_to_consumed ctx abs in - (* Group the two lists *) - let variables_values = - List.combine given_back_variables consumed_values - in - (* Sanity check: the two lists match (same types) *) - List.iter - (fun (var, v) -> assert ((var : var).ty = (v : texpression).ty)) - variables_values; - (* Translate the next expression *) - let next_e = translate_expression config e ctx in - (* Generate the assignemnts *) - let monadic = false in - List.fold_right - (fun (var, value) (e : texpression) -> - mk_let monadic (mk_typed_pattern_from_var var None) value e) - variables_values next_e - | V.FunCall -> - let call_info = V.FunCallId.Map.find abs.call_id ctx.calls in - let call = call_info.forward in - let type_args = List.map (ctx_translate_fwd_ty ctx) call.type_params in - (* Retrieve the original call and the parent abstractions *) - let _forward, backwards = get_abs_ancestors ctx abs in - (* Retrieve the values consumed when we called the forward function and - * ended the parent backward functions: those give us part of the input - * values (rmk: for now, as we disallow nested lifetimes, there can't be - * parent backward functions). - * Note that the forward inputs include the input state (if there is one). *) - let fwd_inputs = call_info.forward_inputs in - let back_ancestors_inputs = - List.concat (List.map (fun (_abs, args) -> args) backwards) - in - (* Retrieve the values consumed upon ending the loans inside this - * abstraction: those give us the remaining input values *) - let back_inputs = abs_to_consumed ctx abs in - let inputs = - List.concat [ fwd_inputs; back_ancestors_inputs; back_inputs ] - in - (* Retrieve the values given back by this function: those are the output - * values. We rely on the fact that there are no nested borrows to use the - * meta-place information from the input values given to the forward function - * (we need to add [None] for the return avalue) *) - let output_mpl = - List.append (List.map translate_opt_mplace call.args_places) [ None ] - in - let ctx, outputs = abs_to_given_back output_mpl abs ctx in - (* Group the output values together (note that for now, backward functions - * never return an output state) *) - let output = mk_simpl_tuple_pattern outputs in - (* Sanity check: the inputs and outputs have the proper number and the proper type *) - let fun_id = - match call.call_id with - | S.Fun (fun_id, _) -> fun_id - | Unop _ | Binop _ -> - (* Those don't have backward functions *) - raise (Failure "Unreachable") - in - - let inst_sg = - get_instantiated_fun_sig fun_id (Some abs.back_id) type_args ctx - in - log#ldebug - (lazy - ("\n- fun_id: " ^ A.show_fun_id fun_id ^ "\n- inputs (" - ^ string_of_int (List.length inputs) - ^ "): " - ^ String.concat ", " (List.map show_texpression inputs) - ^ "\n- inst_sg.inputs (" - ^ string_of_int (List.length inst_sg.inputs) - ^ "): " - ^ String.concat ", " (List.map show_ty inst_sg.inputs))); - List.iter - (fun (x, ty) -> assert ((x : texpression).ty = ty)) - (List.combine inputs inst_sg.inputs); - log#ldebug - (lazy - ("\n- outputs: " - ^ string_of_int (List.length outputs) - ^ "\n- expected outputs: " - ^ string_of_int (List.length inst_sg.doutputs))); - List.iter - (fun (x, ty) -> assert ((x : typed_pattern).ty = ty)) - (List.combine outputs inst_sg.doutputs); - (* Retrieve the function id, and register the function call in the context - * if necessary *) - let ctx, func = bs_ctx_register_backward_call abs back_inputs ctx in - (* Translate the next expression *) - let next_e = translate_expression config e ctx in - (* Put everything together *) - let args_mplaces = List.map (fun _ -> None) inputs in - let args = - List.map - (fun (arg, mp) -> mk_opt_mplace_texpression mp arg) - (List.combine inputs args_mplaces) - in - let effect_info = - get_fun_effect_info ctx.fun_context.fun_infos fun_id (Some abs.back_id) - in - let input_tys = (List.map (fun (x : texpression) -> x.ty)) args in - let ret_ty = - if effect_info.can_fail then mk_result_ty output.ty else output.ty - in - let func_ty = mk_arrows input_tys ret_ty in - let func = { id = Func func; type_args } in - let func = { e = Qualif func; ty = func_ty } in - let call = mk_apps func args in - (* **Optimization**: - * ================= - * We do a small optimization here: if the backward function doesn't - * have any output, we don't introduce any function call. - * See the comment in [config]. - *) - if config.filter_useless_back_calls && outputs = [] then ( - (* No outputs - we do a small sanity check: the backward function - * should have exactly the same number of inputs as the forward: - * this number can be different only if the forward function returned - * a value containing mutable borrows, which can't be the case... *) - assert (List.length inputs = List.length fwd_inputs); - next_e) - else mk_let effect_info.can_fail output call next_e - | V.SynthRet -> - (* If we end the abstraction which consumed the return value of the function - we are synthesizing, we get back the borrows which were inside. Those borrows - are actually input arguments of the backward function we are synthesizing. - So we simply need to introduce proper let bindings. - - For instance: - {[ - fn id<'a>(x : &'a mut u32) -> &'a mut u32 { - x - } - ]} - - Upon ending the return abstraction for 'a, we get back the borrow for [x]. - This new value is the second argument of the backward function: - {[ - let id_back x nx = nx - ]} - - In practice, upon ending this abstraction we introduce a useless - let-binding: - {[ - let id_back x nx = - let s = nx in // the name [s] is not important (only collision matters) - ... - ]} - - This let-binding later gets inlined, during a micro-pass. - *) - (* First, retrieve the list of variables used for the inputs for the - * backward function *) - let inputs = T.RegionGroupId.Map.find abs.back_id ctx.backward_inputs in - (* Retrieve the values consumed upon ending the loans inside this - * abstraction: as there are no nested borrows, there should be none. *) - let consumed = abs_to_consumed ctx abs in - assert (consumed = []); - (* Retrieve the values given back upon ending this abstraction - note that - * we don't provide meta-place information, because those assignments will - * be inlined anyway... *) - log#ldebug (lazy ("abs: " ^ abs_to_string ctx abs)); - let ctx, given_back = abs_to_given_back_no_mp abs ctx in - (* Link the inputs to those given back values - note that this also - * checks we have the same number of values, of course *) - let given_back_inputs = List.combine given_back inputs in - (* Sanity check *) - List.iter - (fun ((given_back, input) : typed_pattern * var) -> - log#ldebug - (lazy - ("\n- given_back ty: " - ^ ty_to_string ctx given_back.ty - ^ "\n- sig input ty: " ^ ty_to_string ctx input.ty)); - assert (given_back.ty = input.ty)) - given_back_inputs; - (* Translate the next expression *) - let next_e = translate_expression config e ctx in - (* Generate the assignments *) - let monadic = false in - List.fold_right - (fun (given_back, input_var) e -> - mk_let monadic given_back (mk_texpression_from_var input_var) e) - given_back_inputs next_e - -and translate_global_eval (config : config) (gid : A.GlobalDeclId.id) - (sval : V.symbolic_value) (e : S.expression) (ctx : bs_ctx) : texpression = - let ctx, var = fresh_var_for_symbolic_value sval ctx in - let decl = A.GlobalDeclId.Map.find gid ctx.global_context.llbc_global_decls in - let global_expr = { id = Global gid; type_args = [] } in - (* We use translate_fwd_ty to translate the global type *) - let ty = ctx_translate_fwd_ty ctx decl.ty in - let gval = { e = Qualif global_expr; ty } in - let e = translate_expression config e ctx in - mk_let false (mk_typed_pattern_from_var var None) gval e - -and translate_expansion (config : config) (p : S.mplace option) - (sv : V.symbolic_value) (exp : S.expansion) (ctx : bs_ctx) : texpression = - (* Translate the scrutinee *) - let scrutinee_var = lookup_var_for_symbolic_value sv ctx in - let scrutinee = mk_texpression_from_var scrutinee_var in - let scrutinee_mplace = translate_opt_mplace p in - (* Translate the branches *) - match exp with - | ExpandNoBranch (sexp, e) -> ( - match sexp with - | V.SeConcrete _ -> - (* Actually, we don't *register* symbolic expansions to constant - * values in the symbolic ADT *) - raise (Failure "Unreachable") - | SeMutRef (_, nsv) | SeSharedRef (_, nsv) -> - (* The (mut/shared) borrow type is extracted to identity: we thus simply - * introduce an reassignment *) - let ctx, var = fresh_var_for_symbolic_value nsv ctx in - let next_e = translate_expression config e ctx in - let monadic = false in - mk_let monadic - (mk_typed_pattern_from_var var None) - (mk_opt_mplace_texpression scrutinee_mplace scrutinee) - next_e - | SeAdt _ -> - (* Should be in the [ExpandAdt] case *) - raise (Failure "Unreachable")) - | ExpandAdt branches -> ( - (* We don't do the same thing if there is a branching or not *) - match branches with - | [] -> raise (Failure "Unreachable") - | [ (variant_id, svl, branch) ] -> ( - (* There is exactly one branch: no branching *) - let type_id, _, _ = TypesUtils.ty_as_adt sv.V.sv_ty in - let ctx, vars = fresh_vars_for_symbolic_values svl ctx in - let branch = translate_expression config branch ctx in - match type_id with - | T.AdtId adt_id -> - (* Detect if this is an enumeration or not *) - let tdef = bs_ctx_lookup_llbc_type_decl adt_id ctx in - let is_enum = type_decl_is_enum tdef in - if is_enum then - (* This is an enumeration: introduce an [ExpandEnum] let-binding *) - let variant_id = Option.get variant_id in - let lvars = - List.map (fun v -> mk_typed_pattern_from_var v None) vars - in - let lv = mk_adt_pattern scrutinee.ty variant_id lvars in - let monadic = false in - - mk_let monadic lv - (mk_opt_mplace_texpression scrutinee_mplace scrutinee) - branch - else - (* This is not an enumeration: introduce let-bindings for every - * field. - * We use the [dest] variable in order not to have to recompute - * the type of the result of the projection... *) - let adt_id, type_args = - match scrutinee.ty with - | Adt (adt_id, tys) -> (adt_id, tys) - | _ -> raise (Failure "Unreachable") - in - let gen_field_proj (field_id : FieldId.id) (dest : var) : - texpression = - let proj_kind = { adt_id; field_id } in - let qualif = { id = Proj proj_kind; type_args } in - let proj_e = Qualif qualif in - let proj_ty = mk_arrow scrutinee.ty dest.ty in - let proj = { e = proj_e; ty = proj_ty } in - mk_app proj scrutinee - in - let id_var_pairs = FieldId.mapi (fun fid v -> (fid, v)) vars in - let monadic = false in - List.fold_right - (fun (fid, var) e -> - let field_proj = gen_field_proj fid var in - mk_let monadic - (mk_typed_pattern_from_var var None) - field_proj e) - id_var_pairs branch - | T.Tuple -> - let vars = - List.map (fun x -> mk_typed_pattern_from_var x None) vars - in - let monadic = false in - mk_let monadic - (mk_simpl_tuple_pattern vars) - (mk_opt_mplace_texpression scrutinee_mplace scrutinee) - branch - | T.Assumed T.Box -> - (* There should be exactly one variable *) - let var = - match vars with - | [ v ] -> v - | _ -> raise (Failure "Unreachable") - in - (* We simply introduce an assignment - the box type is the - * identity when extracted ([box a == a]) *) - let monadic = false in - mk_let monadic - (mk_typed_pattern_from_var var None) - (mk_opt_mplace_texpression scrutinee_mplace scrutinee) - branch - | T.Assumed T.Vec -> - (* We can't expand vector values: we can access the fields only - * through the functions provided by the API (note that we don't - * know how to expand a vector, because it has a variable number - * of fields!) *) - failwith "Can't expand a vector value" - | T.Assumed T.Option -> - (* We shouldn't get there in the "one-branch" case: options have - * two variants *) - raise (Failure "Unreachable")) - | branches -> - let translate_branch (variant_id : T.VariantId.id option) - (svl : V.symbolic_value list) (branch : S.expression) : - match_branch = - (* There *must* be a variant id - otherwise there can't be several branches *) - let variant_id = Option.get variant_id in - let ctx, vars = fresh_vars_for_symbolic_values svl ctx in - let vars = - List.map (fun x -> mk_typed_pattern_from_var x None) vars - in - let pat_ty = scrutinee.ty in - let pat = mk_adt_pattern pat_ty variant_id vars in - let branch = translate_expression config branch ctx in - { pat; branch } - in - let branches = - List.map (fun (vid, svl, e) -> translate_branch vid svl e) branches - in - let e = - Switch - ( mk_opt_mplace_texpression scrutinee_mplace scrutinee, - Match branches ) - in - (* There should be at least one branch *) - let branch = List.hd branches in - let ty = branch.branch.ty in - (* Sanity check *) - assert (List.for_all (fun br -> br.branch.ty = ty) branches); - (* Return *) - { e; ty }) - | ExpandBool (true_e, false_e) -> - (* We don't need to update the context: we don't introduce any - * new values/variables *) - let true_e = translate_expression config true_e ctx in - let false_e = translate_expression config false_e ctx in - let e = - Switch - ( mk_opt_mplace_texpression scrutinee_mplace scrutinee, - If (true_e, false_e) ) - in - let ty = true_e.ty in - assert (ty = false_e.ty); - { e; ty } - | ExpandInt (int_ty, branches, otherwise) -> - let translate_branch ((v, branch_e) : V.scalar_value * S.expression) : - match_branch = - (* We don't need to update the context: we don't introduce any - * new values/variables *) - let branch = translate_expression config branch_e ctx in - let pat = mk_typed_pattern_from_constant_value (V.Scalar v) in - { pat; branch } - in - let branches = List.map translate_branch branches in - let otherwise = translate_expression config otherwise ctx in - let pat_ty = Integer int_ty in - let otherwise_pat : typed_pattern = { value = PatDummy; ty = pat_ty } in - let otherwise : match_branch = - { pat = otherwise_pat; branch = otherwise } - in - let all_branches = List.append branches [ otherwise ] in - let e = - Switch - ( mk_opt_mplace_texpression scrutinee_mplace scrutinee, - Match all_branches ) - in - let ty = otherwise.branch.ty in - assert ( - List.for_all (fun (br : match_branch) -> br.branch.ty = ty) branches); - { e; ty } - -and translate_meta (config : config) (meta : S.meta) (e : S.expression) - (ctx : bs_ctx) : texpression = - let next_e = translate_expression config e ctx in - let meta = - match meta with - | S.Assignment (lp, rv, rp) -> - let lp = translate_mplace lp in - let rv = typed_value_to_texpression ctx rv in - let rp = translate_opt_mplace rp in - Assignment (lp, rv, rp) - in - let e = Meta (meta, next_e) in - let ty = next_e.ty in - { e; ty } - -let translate_fun_decl (config : config) (ctx : bs_ctx) - (body : S.expression option) : fun_decl = - (* Translate *) - let def = ctx.fun_decl in - let bid = ctx.bid in - log#ldebug - (lazy - ("SymbolicToPure.translate_fun_decl: " - ^ Print.fun_name_to_string def.A.name - ^ " (" - ^ Print.option_to_string T.RegionGroupId.to_string bid - ^ ")")); - - (* Translate the declaration *) - let def_id = def.A.def_id in - let basename = def.name in - (* Lookup the signature *) - let signature = bs_ctx_lookup_local_function_sig def_id bid ctx in - (* Translate the body, if there is *) - let body = - match body with - | None -> None - | Some body -> - let body = translate_expression config body ctx in - (* Sanity check *) - type_check_texpression ctx body; - (* Introduce the input state, if necessary *) - let effect_info = - get_fun_effect_info ctx.fun_context.fun_infos (Regular def_id) bid - in - let input_state = - if effect_info.input_state then - [ - { - id = ctx.state_var; - basename = Some ConstStrings.state_basename; - ty = mk_state_ty; - }; - ] - else [] - in - (* Compute the list of (properly ordered) input variables *) - let backward_inputs : var list = - match bid with - | None -> [] - | Some back_id -> - let parents_ids = - list_ordered_parent_region_groups def.signature back_id - in - let backward_ids = List.append parents_ids [ back_id ] in - List.concat - (List.map - (fun id -> T.RegionGroupId.Map.find id ctx.backward_inputs) - backward_ids) - in - let inputs = - List.concat [ ctx.forward_inputs; input_state; backward_inputs ] - in - let inputs_lvs = - List.map (fun v -> mk_typed_pattern_from_var v None) inputs - in - (* Sanity check *) - log#ldebug - (lazy - ("SymbolicToPure.translate_fun_decl:" ^ "\n- forward_inputs: " - ^ String.concat ", " (List.map show_var ctx.forward_inputs) - ^ "\n- input_state: " - ^ String.concat ", " (List.map show_var input_state) - ^ "\n- backward_inputs: " - ^ String.concat ", " (List.map show_var backward_inputs) - ^ "\n- signature.inputs: " - ^ String.concat ", " (List.map show_ty signature.inputs))); - assert ( - List.for_all - (fun (var, ty) -> (var : var).ty = ty) - (List.combine inputs signature.inputs)); - Some { inputs; inputs_lvs; body } - in - (* Assemble the declaration *) - let def = - { - def_id; - back_id = bid; - basename; - signature; - is_global_decl_body = def.is_global_decl_body; - body; - } - in - (* Debugging *) - log#ldebug - (lazy - ("SymbolicToPure.translate_fun_decl: translated:\n" - ^ fun_decl_to_string ctx def)); - (* return *) - def - -let translate_type_decls (type_decls : T.type_decl list) : type_decl list = - List.map translate_type_decl type_decls - -(** Translates function signatures. - - Takes as input a list of function information containing: - - the function id - - a list of optional names for the inputs - - the function signature - - Returns a map from forward/backward functions identifiers to: - - translated function signatures - - optional names for the outputs values (we derive them for the backward - functions) - *) -let translate_fun_signatures (fun_infos : FA.fun_info A.FunDeclId.Map.t) - (types_infos : TA.type_infos) - (functions : (A.fun_id * string option list * A.fun_sig) list) : - fun_sig_named_outputs RegularFunIdMap.t = - (* For every function, translate the signatures of: - - the forward function - - the backward functions - *) - let translate_one (fun_id : A.fun_id) (input_names : string option list) - (sg : A.fun_sig) : (regular_fun_id * fun_sig_named_outputs) list = - (* The forward function *) - let fwd_sg = - translate_fun_sig fun_infos fun_id types_infos sg input_names None - in - let fwd_id = (fun_id, None) in - (* The backward functions *) - let back_sgs = - List.map - (fun (rg : T.region_var_group) -> - let tsg = - translate_fun_sig fun_infos fun_id types_infos sg input_names - (Some rg.id) - in - let id = (fun_id, Some rg.id) in - (id, tsg)) - sg.regions_hierarchy - in - (* Return *) - (fwd_id, fwd_sg) :: back_sgs - in - let translated = - List.concat - (List.map (fun (id, names, sg) -> translate_one id names sg) functions) - in - List.fold_left - (fun m (id, sg) -> RegularFunIdMap.add id sg m) - RegularFunIdMap.empty translated diff --git a/src/SynthesizeSymbolic.ml b/src/SynthesizeSymbolic.ml deleted file mode 100644 index a2256bdd..00000000 --- a/src/SynthesizeSymbolic.ml +++ /dev/null @@ -1,156 +0,0 @@ -module C = Collections -module T = Types -module V = Values -module E = Expressions -module A = LlbcAst -open SymbolicAst - -let mk_mplace (p : E.place) (ctx : Contexts.eval_ctx) : mplace = - let bv = Contexts.ctx_lookup_binder ctx p.var_id in - { bv; projection = p.projection } - -let mk_opt_mplace (p : E.place option) (ctx : Contexts.eval_ctx) : mplace option - = - match p with None -> None | Some p -> Some (mk_mplace p ctx) - -let mk_opt_place_from_op (op : E.operand) (ctx : Contexts.eval_ctx) : - mplace option = - match op with - | E.Copy p | E.Move p -> Some (mk_mplace p ctx) - | E.Constant _ -> None - -let synthesize_symbolic_expansion (sv : V.symbolic_value) - (place : mplace option) (seel : V.symbolic_expansion option list) - (exprl : expression list option) : expression option = - match exprl with - | None -> None - | Some exprl -> - let ls = List.combine seel exprl in - (* Match on the symbolic value type to know which can of expansion happened *) - let expansion = - match sv.V.sv_ty with - | T.Bool -> ( - (* Boolean expansion: there should be two branches *) - match ls with - | [ - (Some (V.SeConcrete (V.Bool true)), true_exp); - (Some (V.SeConcrete (V.Bool false)), false_exp); - ] -> - ExpandBool (true_exp, false_exp) - | _ -> failwith "Ill-formed boolean expansion") - | T.Integer int_ty -> - (* Switch over an integer: split between the "regular" branches - and the "otherwise" branch (which should be the last branch) *) - let branches, otherwise = C.List.pop_last ls in - (* For all the regular branches, the symbolic value should have - * been expanded to a constant *) - let get_scalar (see : V.symbolic_expansion option) : V.scalar_value - = - match see with - | Some (V.SeConcrete (V.Scalar cv)) -> - assert (cv.V.int_ty = int_ty); - cv - | _ -> failwith "Unreachable" - in - let branches = - List.map (fun (see, exp) -> (get_scalar see, exp)) branches - in - (* For the otherwise branch, the symbolic value should have been left - * unchanged *) - let otherwise_see, otherwise = otherwise in - assert (otherwise_see = None); - (* Return *) - ExpandInt (int_ty, branches, otherwise) - | T.Adt (_, _, _) -> - (* Branching: it is necessarily an enumeration expansion *) - let get_variant (see : V.symbolic_expansion option) : - T.VariantId.id option * V.symbolic_value list = - match see with - | Some (V.SeAdt (vid, fields)) -> (vid, fields) - | _ -> failwith "Ill-formed branching ADT expansion" - in - let exp = - List.map - (fun (see, exp) -> - let vid, fields = get_variant see in - (vid, fields, exp)) - ls - in - ExpandAdt exp - | T.Ref (_, _, _) -> ( - (* Reference expansion: there should be one branch *) - match ls with - | [ (Some see, exp) ] -> ExpandNoBranch (see, exp) - | _ -> failwith "Ill-formed borrow expansion") - | T.TypeVar _ | Char | Never | Str | Array _ | Slice _ -> - failwith "Ill-formed symbolic expansion" - in - Some (Expansion (place, sv, expansion)) - -let synthesize_symbolic_expansion_no_branching (sv : V.symbolic_value) - (place : mplace option) (see : V.symbolic_expansion) - (expr : expression option) : expression option = - let exprl = match expr with None -> None | Some expr -> Some [ expr ] in - synthesize_symbolic_expansion sv place [ Some see ] exprl - -let synthesize_function_call (call_id : call_id) - (abstractions : V.AbstractionId.id list) (type_params : T.ety list) - (args : V.typed_value list) (args_places : mplace option list) - (dest : V.symbolic_value) (dest_place : mplace option) - (expr : expression option) : expression option = - match expr with - | None -> None - | Some expr -> - let call = - { - call_id; - abstractions; - type_params; - args; - dest; - args_places; - dest_place; - } - in - Some (FunCall (call, expr)) - -let synthesize_global_eval (gid : A.GlobalDeclId.id) (dest : V.symbolic_value) - (expr : expression option) : expression option = - match expr with None -> None | Some e -> Some (EvalGlobal (gid, dest, e)) - -let synthesize_regular_function_call (fun_id : A.fun_id) - (call_id : V.FunCallId.id) (abstractions : V.AbstractionId.id list) - (type_params : T.ety list) (args : V.typed_value list) - (args_places : mplace option list) (dest : V.symbolic_value) - (dest_place : mplace option) (expr : expression option) : expression option - = - synthesize_function_call - (Fun (fun_id, call_id)) - abstractions type_params args args_places dest dest_place expr - -let synthesize_unary_op (unop : E.unop) (arg : V.typed_value) - (arg_place : mplace option) (dest : V.symbolic_value) - (dest_place : mplace option) (expr : expression option) : expression option - = - synthesize_function_call (Unop unop) [] [] [ arg ] [ arg_place ] dest - dest_place expr - -let synthesize_binary_op (binop : E.binop) (arg0 : V.typed_value) - (arg0_place : mplace option) (arg1 : V.typed_value) - (arg1_place : mplace option) (dest : V.symbolic_value) - (dest_place : mplace option) (expr : expression option) : expression option - = - synthesize_function_call (Binop binop) [] [] [ arg0; arg1 ] - [ arg0_place; arg1_place ] dest dest_place expr - -let synthesize_end_abstraction (abs : V.abs) (expr : expression option) : - expression option = - match expr with - | None -> None - | Some expr -> Some (EndAbstraction (abs, expr)) - -let synthesize_assignment (lplace : mplace) (rvalue : V.typed_value) - (rplace : mplace option) (expr : expression option) : expression option = - match expr with - | None -> None - | Some expr -> Some (Meta (Assignment (lplace, rvalue, rplace), expr)) diff --git a/src/Translate.ml b/src/Translate.ml deleted file mode 100644 index 8f3b94c4..00000000 --- a/src/Translate.ml +++ /dev/null @@ -1,871 +0,0 @@ -open InterpreterStatements -open Interpreter -module L = Logging -module T = Types -module A = LlbcAst -module SA = SymbolicAst -module Micro = PureMicroPasses -open PureUtils -open TranslateCore - -(** The local logger *) -let log = TranslateCore.log - -type config = { - eval_config : Contexts.partial_config; - mp_config : Micro.config; - use_state : bool; - (** Controls whether we need to use a state to model the external world - (I/O, for instance). - *) - split_files : bool; - (** Controls whether we split the generated definitions between different - files for the types, clauses and functions, or if we group them in - one file. - *) - test_unit_functions : bool; - (** If true, insert tests in the generated files to check that the - unit functions normalize to [Success _]. - - For instance, in F* it generates code like this: - {[ - let _ = assert_norm (FUNCTION () = Success ()) - ]} - *) - extract_decreases_clauses : bool; - (** If [true], insert [decreases] clauses for all the recursive definitions. - - The body of such clauses must be defined by the user. - *) - extract_template_decreases_clauses : bool; - (** In order to help the user, we can generate "template" decrease clauses - (i.e., definitions with proper signatures but dummy bodies) in a - dedicated file. - *) -} - -(** The result of running the symbolic interpreter on a function: - - the list of symbolic values used for the input values - - the generated symbolic AST -*) -type symbolic_fun_translation = V.symbolic_value list * SA.expression - -(** Execute the symbolic interpreter on a function to generate a list of symbolic ASTs, - for the forward function and the backward functions. -*) -let translate_function_to_symbolics (config : C.partial_config) - (trans_ctx : trans_ctx) (fdef : A.fun_decl) : - (symbolic_fun_translation * symbolic_fun_translation list) option = - (* Debug *) - log#ldebug - (lazy - ("translate_function_to_symbolics: " - ^ Print.fun_name_to_string fdef.A.name)); - - let { type_context; fun_context; global_context } = trans_ctx in - let fun_context = { C.fun_decls = fun_context.fun_decls } in - - match fdef.body with - | None -> None - | Some _ -> - (* Evaluate *) - let synthesize = true in - let evaluate gid = - let inputs, symb = - evaluate_function_symbolic config synthesize type_context fun_context - global_context fdef gid - in - (inputs, Option.get symb) - in - (* Execute the forward function *) - let forward = evaluate None in - (* Execute the backward functions *) - let backwards = - T.RegionGroupId.mapi - (fun gid _ -> evaluate (Some gid)) - fdef.signature.regions_hierarchy - in - - (* Return *) - Some (forward, backwards) - -(** Translate a function, by generating its forward and backward translations. - - [fun_sigs]: maps the forward/backward functions to their signatures. In case - of backward functions, we also provide names for the outputs. - TODO: maybe we should introduce a record for this. -*) -let translate_function_to_pure (config : C.partial_config) - (mp_config : Micro.config) (trans_ctx : trans_ctx) - (fun_sigs : SymbolicToPure.fun_sig_named_outputs RegularFunIdMap.t) - (pure_type_decls : Pure.type_decl Pure.TypeDeclId.Map.t) (fdef : A.fun_decl) - : pure_fun_translation = - (* Debug *) - log#ldebug - (lazy - ("translate_function_to_pure: " ^ Print.fun_name_to_string fdef.A.name)); - - let { type_context; fun_context; global_context } = trans_ctx in - let def_id = fdef.def_id in - - (* Compute the symbolic ASTs, if the function is transparent *) - let symbolic_trans = translate_function_to_symbolics config trans_ctx fdef in - let symbolic_forward, symbolic_backwards = - match symbolic_trans with - | None -> (None, None) - | Some (fwd, backs) -> (Some fwd, Some backs) - in - - (* Convert the symbolic ASTs to pure ASTs: *) - - (* Initialize the context *) - let forward_sig = RegularFunIdMap.find (A.Regular def_id, None) fun_sigs in - let sv_to_var = V.SymbolicValueId.Map.empty in - let var_counter = Pure.VarId.generator_zero in - let state_var, var_counter = Pure.VarId.fresh var_counter in - let calls = V.FunCallId.Map.empty in - let abstractions = V.AbstractionId.Map.empty in - let type_context = - { - SymbolicToPure.types_infos = type_context.type_infos; - llbc_type_decls = type_context.type_decls; - type_decls = pure_type_decls; - } - in - let fun_context = - { - SymbolicToPure.llbc_fun_decls = fun_context.fun_decls; - fun_sigs; - fun_infos = fun_context.fun_infos; - } - in - let global_context = - { SymbolicToPure.llbc_global_decls = global_context.global_decls } - in - let ctx = - { - SymbolicToPure.bid = None; - (* Dummy for now *) - sg = forward_sig.sg; - (* Will need to be updated for the backward functions *) - sv_to_var; - var_counter; - state_var; - type_context; - fun_context; - global_context; - fun_decl = fdef; - forward_inputs = []; - (* Empty for now *) - backward_inputs = T.RegionGroupId.Map.empty; - (* Empty for now *) - backward_outputs = T.RegionGroupId.Map.empty; - (* Empty for now *) - calls; - abstractions; - } - in - - (* We need to initialize the input/output variables *) - let num_forward_inputs = List.length fdef.signature.inputs in - let add_forward_inputs input_svs ctx = - match fdef.body with - | None -> ctx - | Some body -> - let forward_input_vars = LlbcAstUtils.fun_body_get_input_vars body in - let forward_input_varnames = - List.map (fun (v : A.var) -> v.name) forward_input_vars - in - let input_svs = List.combine forward_input_varnames input_svs in - let ctx, forward_inputs = - SymbolicToPure.fresh_named_vars_for_symbolic_values input_svs ctx - in - { ctx with forward_inputs } - in - - (* The symbolic to pure config *) - let sp_config = - { - SymbolicToPure.filter_useless_back_calls = - mp_config.filter_useless_monadic_calls; - } - in - - (* Translate the forward function *) - let pure_forward = - match symbolic_forward with - | None -> SymbolicToPure.translate_fun_decl sp_config ctx None - | Some (fwd_svs, fwd_ast) -> - SymbolicToPure.translate_fun_decl sp_config - (add_forward_inputs fwd_svs ctx) - (Some fwd_ast) - in - - (* Translate the backward functions *) - let translate_backward (rg : T.region_var_group) : Pure.fun_decl = - (* For the backward inputs/outputs initialization: we use the fact that - * there are no nested borrows for now, and so that the region groups - * can't have parents *) - assert (rg.parents = []); - let back_id = rg.id in - - match symbolic_backwards with - | None -> - (* Initialize the context - note that the ret_ty is not really - * useful as we don't translate a body *) - let backward_sg = - RegularFunIdMap.find (A.Regular def_id, Some back_id) fun_sigs - in - let ctx = { ctx with bid = Some back_id; sg = backward_sg.sg } in - - (* Translate *) - SymbolicToPure.translate_fun_decl sp_config ctx None - | Some symbolic_backwards -> - let input_svs, symbolic = - T.RegionGroupId.nth symbolic_backwards back_id - in - let ctx = add_forward_inputs input_svs ctx in - (* TODO: the computation of the backward inputs is a bit awckward... *) - let backward_sg = - RegularFunIdMap.find (A.Regular def_id, Some back_id) fun_sigs - in - (* We need to ignore the forward inputs, and the state input (if there is) *) - let fun_info = - SymbolicToPure.get_fun_effect_info fun_context.fun_infos - (A.Regular def_id) (Some back_id) - in - let _, backward_inputs = - Collections.List.split_at backward_sg.sg.inputs - (num_forward_inputs + if fun_info.input_state then 1 else 0) - in - (* As we forbid nested borrows, the additional inputs for the backward - * functions come from the borrows in the return value of the rust function: - * we thus use the name "ret" for those inputs *) - let backward_inputs = - List.map (fun ty -> (Some "ret", ty)) backward_inputs - in - let ctx, backward_inputs = - SymbolicToPure.fresh_vars backward_inputs ctx - in - (* The outputs for the backward functions, however, come from borrows - * present in the input values of the rust function: for those we reuse - * the names of the input values. *) - let backward_outputs = - List.combine backward_sg.output_names backward_sg.sg.doutputs - in - let ctx, backward_outputs = - SymbolicToPure.fresh_vars backward_outputs ctx - in - let backward_inputs = - T.RegionGroupId.Map.singleton back_id backward_inputs - in - let backward_outputs = - T.RegionGroupId.Map.singleton back_id backward_outputs - in - - (* Put everything in the context *) - let ctx = - { - ctx with - bid = Some back_id; - sg = backward_sg.sg; - backward_inputs; - backward_outputs; - } - in - - (* Translate *) - SymbolicToPure.translate_fun_decl sp_config ctx (Some symbolic) - in - let pure_backwards = - List.map translate_backward fdef.signature.regions_hierarchy - in - - (* Return *) - (pure_forward, pure_backwards) - -let translate_module_to_pure (config : C.partial_config) - (mp_config : Micro.config) (use_state : bool) (crate : Crates.llbc_crate) : - trans_ctx * Pure.type_decl list * (bool * pure_fun_translation) list = - (* Debug *) - log#ldebug (lazy "translate_module_to_pure"); - - (* Compute the type and function contexts *) - let type_context, fun_context, global_context = - compute_type_fun_global_contexts crate - in - let fun_infos = - FA.analyze_module crate fun_context.C.fun_decls - global_context.C.global_decls use_state - in - let fun_context = { fun_decls = fun_context.fun_decls; fun_infos } in - let trans_ctx = { type_context; fun_context; global_context } in - - (* Translate all the type definitions *) - let type_decls = SymbolicToPure.translate_type_decls crate.types in - - (* Compute the type definition map *) - let type_decls_map = - Pure.TypeDeclId.Map.of_list - (List.map (fun (def : Pure.type_decl) -> (def.def_id, def)) type_decls) - in - - (* Translate all the function *signatures* *) - let assumed_sigs = - List.map - (fun (id, sg, _, _) -> - (A.Assumed id, List.map (fun _ -> None) (sg : A.fun_sig).inputs, sg)) - Assumed.assumed_infos - in - let local_sigs = - List.map - (fun (fdef : A.fun_decl) -> - let input_names = - match fdef.body with - | None -> List.map (fun _ -> None) fdef.signature.inputs - | Some body -> - List.map - (fun (v : A.var) -> v.name) - (LlbcAstUtils.fun_body_get_input_vars body) - in - (A.Regular fdef.def_id, input_names, fdef.signature)) - crate.functions - in - let sigs = List.append assumed_sigs local_sigs in - let fun_sigs = - SymbolicToPure.translate_fun_signatures fun_context.fun_infos - type_context.type_infos sigs - in - - (* Translate all the *transparent* functions *) - let pure_translations = - List.map - (translate_function_to_pure config mp_config trans_ctx fun_sigs - type_decls_map) - crate.functions - in - - (* Apply the micro-passes *) - let pure_translations = - List.map - (Micro.apply_passes_to_pure_fun_translation mp_config trans_ctx) - pure_translations - in - - (* Return *) - (trans_ctx, type_decls, pure_translations) - -(** Extraction context *) -type gen_ctx = { - crate : Crates.llbc_crate; - extract_ctx : PureToExtract.extraction_ctx; - trans_types : Pure.type_decl Pure.TypeDeclId.Map.t; - trans_funs : (bool * pure_fun_translation) A.FunDeclId.Map.t; - functions_with_decreases_clause : A.FunDeclId.Set.t; -} - -type gen_config = { - mp_config : Micro.config; - use_state : bool; - extract_types : bool; - extract_decreases_clauses : bool; - extract_template_decreases_clauses : bool; - extract_fun_decls : bool; - extract_transparent : bool; - (** If [true], extract the transparent declarations, otherwise ignore. *) - extract_opaque : bool; - (** If [true], extract the opaque declarations, otherwise ignore. *) - extract_state_type : bool; - (** If [true], generate a definition/declaration for the state type *) - interface : bool; - (** [true] if we generate an interface file, [false] otherwise. - For now, this only impacts whether we use [val] or [assume val] for the - opaque definitions. In the future, we might want to extract all the - declarations in an interface file, together with an implementation file - if needed. - *) - test_unit_functions : bool; -} - -(** Returns the pair: (has opaque type decls, has opaque fun decls) *) -let module_has_opaque_decls (ctx : gen_ctx) : bool * bool = - let has_opaque_types = - Pure.TypeDeclId.Map.exists - (fun _ (d : Pure.type_decl) -> - match d.kind with Opaque -> true | _ -> false) - ctx.trans_types - in - let has_opaque_funs = - A.FunDeclId.Map.exists - (fun _ ((_, (t_fwd, _)) : bool * pure_fun_translation) -> - Option.is_none t_fwd.body) - ctx.trans_funs - in - (has_opaque_types, has_opaque_funs) - -(** A generic utility to generate the extracted definitions: as we may want to - split the definitions between different files (or not), we can control - what is precisely extracted. - *) -let extract_definitions (fmt : Format.formatter) (config : gen_config) - (ctx : gen_ctx) : unit = - (* Export the definition groups to the file, in the proper order *) - let export_type (qualif : ExtractToFStar.type_decl_qualif) - (id : Pure.TypeDeclId.id) : unit = - (* Retrive the declaration *) - let def = Pure.TypeDeclId.Map.find id ctx.trans_types in - (* Update the qualifier, if the type is opaque *) - let is_opaque, qualif = - match def.kind with - | Enum _ | Struct _ -> (false, qualif) - | Opaque -> - let qualif = - if config.interface then ExtractToFStar.TypeVal - else ExtractToFStar.AssumeType - in - (true, qualif) - in - (* Extract, if the config instructs to do so (depending on whether the type - * is opaque or not) *) - if - (is_opaque && config.extract_opaque) - || ((not is_opaque) && config.extract_transparent) - then ExtractToFStar.extract_type_decl ctx.extract_ctx fmt qualif def - in - - (* Utility to check a function has a decrease clause *) - let has_decreases_clause (def : Pure.fun_decl) : bool = - A.FunDeclId.Set.mem def.def_id ctx.functions_with_decreases_clause - in - - (* In case of (non-mutually) recursive functions, we use a simple procedure to - * check if the forward and backward functions are mutually recursive. - *) - let export_functions (is_rec : bool) - (pure_ls : (bool * pure_fun_translation) list) : unit = - (* Concatenate the function definitions, filtering the useless forward - * functions. We also make pairs: (forward function, backward function) - * (the forward function contains useful information that we want to keep) *) - let fls = - List.concat - (List.map - (fun (keep_fwd, (fwd, back_ls)) -> - let back_ls = List.map (fun back -> (fwd, back)) back_ls in - if keep_fwd then (fwd, fwd) :: back_ls else back_ls) - pure_ls) - in - (* Extract the decrease clauses template bodies *) - if config.extract_template_decreases_clauses then - List.iter - (fun (_, (fwd, _)) -> - let has_decr_clause = has_decreases_clause fwd in - if has_decr_clause then - ExtractToFStar.extract_template_decreases_clause ctx.extract_ctx fmt - fwd) - pure_ls; - (* Extract the function definitions *) - (if config.extract_fun_decls then - (* Check if the functions are mutually recursive - this really works - * to check if the forward and backward translations of a single - * recursive function are mutually recursive *) - let is_mut_rec = - if is_rec then - if List.length pure_ls <= 1 then - not (PureUtils.functions_not_mutually_recursive (List.map fst fls)) - else true - else false - in - List.iteri - (fun i (fwd_def, def) -> - let is_opaque = Option.is_none fwd_def.Pure.body in - let qualif = - if is_opaque then - if config.interface then ExtractToFStar.Val - else ExtractToFStar.AssumeVal - else if not is_rec then ExtractToFStar.Let - else if is_mut_rec then - if i = 0 then ExtractToFStar.LetRec else ExtractToFStar.And - else ExtractToFStar.LetRec - in - let has_decr_clause = - has_decreases_clause def && config.extract_decreases_clauses - in - (* Check if the definition needs to be filtered or not *) - if - ((not is_opaque) && config.extract_transparent) - || (is_opaque && config.extract_opaque) - then - ExtractToFStar.extract_fun_decl ctx.extract_ctx fmt qualif - has_decr_clause def) - fls); - (* Insert unit tests if necessary *) - if config.test_unit_functions then - List.iter - (fun (keep_fwd, (fwd, _)) -> - if keep_fwd then - ExtractToFStar.extract_unit_test_if_unit_fun ctx.extract_ctx fmt fwd) - pure_ls - in - - (* TODO: Check correct behaviour with opaque globals *) - let export_global (id : A.GlobalDeclId.id) : unit = - let global_decls = ctx.extract_ctx.trans_ctx.global_context.global_decls in - let global = A.GlobalDeclId.Map.find id global_decls in - let _, (body, body_backs) = - A.FunDeclId.Map.find global.body_id ctx.trans_funs - in - assert (List.length body_backs = 0); - - let is_opaque = Option.is_none body.Pure.body in - if - ((not is_opaque) && config.extract_transparent) - || (is_opaque && config.extract_opaque) - then - ExtractToFStar.extract_global_decl ctx.extract_ctx fmt global body - config.interface - in - - let export_state_type () : unit = - let qualif = - if config.interface then ExtractToFStar.TypeVal - else ExtractToFStar.AssumeType - in - ExtractToFStar.extract_state_type fmt ctx.extract_ctx qualif - in - - let export_decl (decl : Crates.declaration_group) : unit = - match decl with - | Type (NonRec id) -> - if config.extract_types then export_type ExtractToFStar.Type id - | Type (Rec ids) -> - (* Rk.: we shouldn't have (mutually) recursive opaque types *) - if config.extract_types then - List.iteri - (fun i id -> - let qualif = - if i = 0 then ExtractToFStar.Type else ExtractToFStar.And - in - export_type qualif id) - ids - | Fun (NonRec id) -> - (* Lookup *) - let pure_fun = A.FunDeclId.Map.find id ctx.trans_funs in - (* Translate *) - export_functions false [ pure_fun ] - | Fun (Rec ids) -> - (* General case of mutually recursive functions *) - (* Lookup *) - let pure_funs = - List.map (fun id -> A.FunDeclId.Map.find id ctx.trans_funs) ids - in - (* Translate *) - export_functions true pure_funs - | Global id -> export_global id - in - - (* If we need to export the state type: we try to export it after we defined - * the type definitions, because if the user wants to define a model for the - * type, he might want to reuse them in the state type. - * More specifically: if we extract functions, we have no choice but to define - * the state type before the functions, because they may reuse this state - * type: in this case, we define/declare it at the very beginning. Otherwise, - * we define/declare it at the very end. - *) - if config.extract_state_type && config.extract_fun_decls then - export_state_type (); - List.iter export_decl ctx.crate.declarations; - if config.extract_state_type && not config.extract_fun_decls then - export_state_type () - -let extract_file (config : gen_config) (ctx : gen_ctx) (filename : string) - (rust_module_name : string) (module_name : string) (custom_msg : string) - (custom_imports : string list) (custom_includes : string list) : unit = - (* Open the file and create the formatter *) - let out = open_out filename in - let fmt = Format.formatter_of_out_channel out in - - (* Print the headers. - * Note that we don't use the OCaml formatter for purpose: we want to control - * line insertion (we have to make sure that some instructions like [open MODULE] - * are printed on one line!). - * This is ok as long as we end up with a line break, so that the formatter's - * internal count is consistent with the state of the file. - *) - (* Create the header *) - Printf.fprintf out "(** THIS FILE WAS AUTOMATICALLY GENERATED BY AENEAS *)\n"; - Printf.fprintf out "(** [%s]%s *)\n" rust_module_name custom_msg; - Printf.fprintf out "module %s\n" module_name; - Printf.fprintf out "open Primitives\n"; - (* Add the custom imports *) - List.iter (fun m -> Printf.fprintf out "open %s\n" m) custom_imports; - (* Add the custom includes *) - List.iter (fun m -> Printf.fprintf out "include %s\n" m) custom_includes; - (* Z3 options - note that we use fuel 1 because it its useful for the decrease clauses *) - Printf.fprintf out "\n#set-options \"--z3rlimit 50 --fuel 1 --ifuel 1\"\n"; - - (* From now onwards, we use the formatter *) - (* Set the margin *) - Format.pp_set_margin fmt 80; - - (* Create a vertical box *) - Format.pp_open_vbox fmt 0; - - (* Extract the definitions *) - extract_definitions fmt config ctx; - - (* Close the box and end the formatting *) - Format.pp_close_box fmt (); - Format.pp_print_newline fmt (); - - (* Some logging *) - log#linfo (lazy ("Generated: " ^ filename)); - - (* Flush and close the file *) - close_out out - -(** Translate a module and write the synthesized code to an output file. - TODO: rename to translate_crate - *) -let translate_module (filename : string) (dest_dir : string) (config : config) - (crate : Crates.llbc_crate) : unit = - (* Translate the module to the pure AST *) - let trans_ctx, trans_types, trans_funs = - translate_module_to_pure config.eval_config config.mp_config - config.use_state crate - in - - (* Initialize the extraction context - for now we extract only to F* *) - let names_map = - PureToExtract.initialize_names_map ExtractToFStar.fstar_names_map_init - in - let variant_concatenate_type_name = true in - let fstar_fmt = - ExtractToFStar.mk_formatter trans_ctx crate.name - variant_concatenate_type_name - in - let ctx = - { PureToExtract.trans_ctx; names_map; fmt = fstar_fmt; indent_incr = 2 } - in - - (* We need to compute which functions are recursive, in order to know - * whether we should generate a decrease clause or not. *) - let rec_functions = - A.FunDeclId.Set.of_list - (List.concat - (List.map - (fun decl -> - match decl with Crates.Fun (Rec ids) -> ids | _ -> []) - crate.declarations)) - in - - (* Register unique names for all the top-level types, globals and functions. - * Note that the order in which we generate the names doesn't matter: - * we just need to generate a mapping from identifier to name, and make - * sure there are no name clashes. *) - let ctx = - List.fold_left - (fun ctx def -> ExtractToFStar.extract_type_decl_register_names ctx def) - ctx trans_types - in - - let ctx = - List.fold_left - (fun ctx (keep_fwd, def) -> - (* We generate a decrease clause for all the recursive functions *) - let gen_decr_clause = - A.FunDeclId.Set.mem (fst def).Pure.def_id rec_functions - in - (* Register the names, only if the function is not a global body - - * those are handled later *) - let is_global = (fst def).Pure.is_global_decl_body in - if is_global then ctx - else - ExtractToFStar.extract_fun_decl_register_names ctx keep_fwd - gen_decr_clause def) - ctx trans_funs - in - - let ctx = - List.fold_left ExtractToFStar.extract_global_decl_register_names ctx - crate.globals - in - - (* Open the output file *) - (* First compute the filename by replacing the extension and converting the - * case (rust module names are snake case) *) - let module_name, extract_filebasename = - match Filename.chop_suffix_opt ~suffix:".llbc" filename with - | None -> - (* Note that we already checked the suffix upon opening the file *) - failwith "Unreachable" - | Some filename -> - (* Retrieve the file basename *) - let basename = Filename.basename filename in - (* Convert the case *) - let module_name = StringUtils.to_camel_case basename in - (* Concatenate *) - (module_name, Filename.concat dest_dir module_name) - in - - (* Put the translated definitions in maps *) - let trans_types = - Pure.TypeDeclId.Map.of_list - (List.map (fun (d : Pure.type_decl) -> (d.def_id, d)) trans_types) - in - let trans_funs = - A.FunDeclId.Map.of_list - (List.map - (fun ((keep_fwd, (fd, bdl)) : bool * pure_fun_translation) -> - (fd.def_id, (keep_fwd, (fd, bdl)))) - trans_funs) - in - - (* Create the directory, if necessary *) - if not (Sys.file_exists dest_dir) then ( - log#linfo (lazy ("Creating missing directory: " ^ dest_dir)); - (* Create a directory with *default* permissions *) - Core_unix.mkdir_p dest_dir); - - (* Copy "Primitives.fst" - I couldn't find a "cp" function in the OCaml - * libraries... *) - let _ = - let src = open_in "fstar/Primitives.fst" in - let tgt_filename = Filename.concat dest_dir "Primitives.fst" in - let tgt = open_out tgt_filename in - try - while true do - (* We copy line by line *) - let line = input_line src in - Printf.fprintf tgt "%s\n" line - done - with End_of_file -> - close_in src; - close_out tgt; - log#linfo (lazy ("Copied: " ^ tgt_filename)) - in - - (* Extract the file(s) *) - let gen_ctx = - { - crate; - extract_ctx = ctx; - trans_types; - trans_funs; - functions_with_decreases_clause = rec_functions; - } - in - - let use_state = config.use_state in - - (* Extract one or several files, depending on the configuration *) - if config.split_files then ( - let base_gen_config = - { - mp_config = config.mp_config; - use_state; - extract_types = false; - extract_decreases_clauses = config.extract_decreases_clauses; - extract_template_decreases_clauses = false; - extract_fun_decls = false; - extract_transparent = true; - extract_opaque = false; - extract_state_type = false; - interface = false; - test_unit_functions = false; - } - in - - (* Check if there are opaque types and functions - in which case we need - * to split *) - let has_opaque_types, has_opaque_funs = module_has_opaque_decls gen_ctx in - let has_opaque_types = has_opaque_types || use_state in - - (* Extract the types *) - (* If there are opaque types, we extract in an interface *) - let types_filename_ext = if has_opaque_types then ".fsti" else ".fst" in - let types_filename = extract_filebasename ^ ".Types" ^ types_filename_ext in - let types_module = module_name ^ ".Types" in - let types_config = - { - base_gen_config with - extract_types = true; - extract_opaque = true; - extract_state_type = use_state; - interface = has_opaque_types; - } - in - extract_file types_config gen_ctx types_filename crate.Crates.name - types_module ": type definitions" [] []; - - (* Extract the template clauses *) - let needs_clauses_module = - config.extract_decreases_clauses - && not (A.FunDeclId.Set.is_empty rec_functions) - in - (if needs_clauses_module && config.extract_template_decreases_clauses then - let clauses_filename = extract_filebasename ^ ".Clauses.Template.fst" in - let clauses_module = module_name ^ ".Clauses.Template" in - let clauses_config = - { base_gen_config with extract_template_decreases_clauses = true } - in - extract_file clauses_config gen_ctx clauses_filename crate.Crates.name - clauses_module ": templates for the decreases clauses" [ types_module ] - []); - - (* Extract the opaque functions, if needed *) - let opaque_funs_module = - if has_opaque_funs then ( - let opaque_filename = extract_filebasename ^ ".Opaque.fsti" in - let opaque_module = module_name ^ ".Opaque" in - let opaque_config = - { - base_gen_config with - extract_fun_decls = true; - extract_transparent = false; - extract_opaque = true; - interface = true; - } - in - extract_file opaque_config gen_ctx opaque_filename crate.Crates.name - opaque_module ": opaque function definitions" [] [ types_module ]; - [ opaque_module ]) - else [] - in - - (* Extract the functions *) - let fun_filename = extract_filebasename ^ ".Funs.fst" in - let fun_module = module_name ^ ".Funs" in - let fun_config = - { - base_gen_config with - extract_fun_decls = true; - test_unit_functions = config.test_unit_functions; - } - in - let clauses_module = - if needs_clauses_module then [ module_name ^ ".Clauses" ] else [] - in - extract_file fun_config gen_ctx fun_filename crate.Crates.name fun_module - ": function definitions" [] - ([ types_module ] @ opaque_funs_module @ clauses_module)) - else - let gen_config = - { - mp_config = config.mp_config; - use_state; - extract_types = true; - extract_decreases_clauses = config.extract_decreases_clauses; - extract_template_decreases_clauses = - config.extract_template_decreases_clauses; - extract_fun_decls = true; - extract_transparent = true; - extract_opaque = true; - extract_state_type = use_state; - interface = false; - test_unit_functions = config.test_unit_functions; - } - in - (* Add the extension for F* *) - let extract_filename = extract_filebasename ^ ".fst" in - extract_file gen_config gen_ctx extract_filename crate.Crates.name - module_name "" [] [] diff --git a/src/TranslateCore.ml b/src/TranslateCore.ml deleted file mode 100644 index a658147d..00000000 --- a/src/TranslateCore.ml +++ /dev/null @@ -1,65 +0,0 @@ -(** Some utilities for the translation *) - -open InterpreterStatements -module L = Logging -module T = Types -module A = LlbcAst -module SA = SymbolicAst -module FA = FunsAnalysis - -(** The local logger *) -let log = L.translate_log - -type type_context = C.type_context [@@deriving show] - -type fun_context = { - fun_decls : A.fun_decl A.FunDeclId.Map.t; - fun_infos : FA.fun_info A.FunDeclId.Map.t; -} -[@@deriving show] - -type global_context = C.global_context [@@deriving show] - -type trans_ctx = { - type_context : type_context; - fun_context : fun_context; - global_context : global_context; -} - -type pure_fun_translation = Pure.fun_decl * Pure.fun_decl list - -let type_decl_to_string (ctx : trans_ctx) (def : Pure.type_decl) : string = - let type_params = def.type_params in - let type_decls = ctx.type_context.type_decls in - let fmt = PrintPure.mk_type_formatter type_decls type_params in - PrintPure.type_decl_to_string fmt def - -let type_id_to_string (ctx : trans_ctx) (def : Pure.type_decl) : string = - let type_params = def.type_params in - let type_decls = ctx.type_context.type_decls in - let fmt = PrintPure.mk_type_formatter type_decls type_params in - PrintPure.type_decl_to_string fmt def - -let fun_sig_to_string (ctx : trans_ctx) (sg : Pure.fun_sig) : string = - let type_params = sg.type_params in - let type_decls = ctx.type_context.type_decls in - let fun_decls = ctx.fun_context.fun_decls in - let global_decls = ctx.global_context.global_decls in - let fmt = - PrintPure.mk_ast_formatter type_decls fun_decls global_decls type_params - in - PrintPure.fun_sig_to_string fmt sg - -let fun_decl_to_string (ctx : trans_ctx) (def : Pure.fun_decl) : string = - let type_params = def.signature.type_params in - let type_decls = ctx.type_context.type_decls in - let fun_decls = ctx.fun_context.fun_decls in - let global_decls = ctx.global_context.global_decls in - let fmt = - PrintPure.mk_ast_formatter type_decls fun_decls global_decls type_params - in - PrintPure.fun_decl_to_string fmt def - -let fun_decl_id_to_string (ctx : trans_ctx) (id : A.FunDeclId.id) : string = - Print.fun_name_to_string - (A.FunDeclId.Map.find id ctx.fun_context.fun_decls).name diff --git a/src/Types.ml b/src/Types.ml deleted file mode 100644 index 326ef76f..00000000 --- a/src/Types.ml +++ /dev/null @@ -1,208 +0,0 @@ -open Identifiers -open Names -open Meta -module TypeVarId = IdGen () -module TypeDeclId = IdGen () -module VariantId = IdGen () -module FieldId = IdGen () - -(** Region variable ids. Used in function signatures. *) -module RegionVarId = IdGen () - -(** Region ids. Used for symbolic executions. *) -module RegionId = IdGen () - -module RegionGroupId = IdGen () - -type ('id, 'name) indexed_var = { - index : 'id; (** Unique index identifying the variable *) - name : 'name; (** Variable name *) -} -[@@deriving show] - -type type_var = (TypeVarId.id, string) indexed_var [@@deriving show] -type region_var = (RegionVarId.id, string option) indexed_var [@@deriving show] - -(** A region. - - Regions are used in function signatures (in which case we use region variable - ids) and in symbolic variables and projections (in which case we use region - ids). - *) -type 'rid region = - | Static (** Static region *) - | Var of 'rid (** Non-static region *) -[@@deriving show, ord] - -(** The type of erased regions. - - We could use unit, but having a dedicated type makes things more explicit. - *) -type erased_region = Erased [@@deriving show, ord] - -(** A group of regions. - - Results from a lifetime analysis: we group the regions with the same - lifetime together, and compute the hierarchy between the regions. - This is necessary to introduce the proper abstraction with the - proper constraints, when evaluating a function call in symbolic mode. -*) -type ('id, 'r) g_region_group = { - id : 'id; - regions : 'r list; - parents : 'id list; -} -[@@deriving show] - -type ('r, 'id) g_region_groups = ('r, 'id) g_region_group list [@@deriving show] - -type region_var_group = (RegionGroupId.id, RegionVarId.id) g_region_group -[@@deriving show] - -type region_var_groups = (RegionGroupId.id, RegionVarId.id) g_region_groups -[@@deriving show] - -type integer_type = - | Isize - | I8 - | I16 - | I32 - | I64 - | I128 - | Usize - | U8 - | U16 - | U32 - | U64 - | U128 -[@@deriving show, ord] - -let all_signed_int_types = [ Isize; I8; I16; I32; I64; I128 ] -let all_unsigned_int_types = [ Usize; U8; U16; U32; U64; U128 ] -let all_int_types = List.append all_signed_int_types all_unsigned_int_types - -type ref_kind = Mut | Shared [@@deriving show, ord] -type assumed_ty = Box | Vec | Option [@@deriving show, ord] - -(** The variant id for [Option::None] *) -let option_none_id = VariantId.of_int 0 - -(** The variant id for [Option::Some] *) -let option_some_id = VariantId.of_int 1 - -(** Type identifier for ADTs. - - ADTs are very general in our encoding: they account for "regular" ADTs, - tuples and also assumed types. -*) -type type_id = AdtId of TypeDeclId.id | Tuple | Assumed of assumed_ty -[@@deriving show, ord] - -(** Ancestor for iter visitor for [ty] *) -class ['self] iter_ty_base = - object (_self : 'self) - inherit [_] VisitorsRuntime.iter - method visit_'r : 'env -> 'r -> unit = fun _ _ -> () - method visit_id : 'env -> TypeVarId.id -> unit = fun _ _ -> () - method visit_type_id : 'env -> type_id -> unit = fun _ _ -> () - method visit_integer_type : 'env -> integer_type -> unit = fun _ _ -> () - method visit_ref_kind : 'env -> ref_kind -> unit = fun _ _ -> () - end - -(** Ancestor for map visitor for [ty] *) -class ['self] map_ty_base = - object (_self : 'self) - inherit [_] VisitorsRuntime.map - method visit_'r : 'env -> 'r -> 'r = fun _ r -> r - method visit_id : 'env -> TypeVarId.id -> TypeVarId.id = fun _ id -> id - method visit_type_id : 'env -> type_id -> type_id = fun _ id -> id - - method visit_integer_type : 'env -> integer_type -> integer_type = - fun _ ity -> ity - - method visit_ref_kind : 'env -> ref_kind -> ref_kind = fun _ rk -> rk - end - -type 'r ty = - | Adt of type_id * 'r list * 'r ty list - (** {!Adt} encodes ADTs, tuples and assumed types *) - | TypeVar of TypeVarId.id - | Bool - | Char - | Never - | Integer of integer_type - | Str - | Array of 'r ty (* TODO: there should be a constant with the array *) - | Slice of 'r ty - | Ref of 'r * 'r ty * ref_kind -[@@deriving - show, - ord, - visitors - { - name = "iter_ty"; - variety = "iter"; - ancestors = [ "iter_ty_base" ]; - nude = true (* Don't inherit {!VisitorsRuntime.iter} *); - concrete = true; - polymorphic = false; - }, - visitors - { - name = "map_ty"; - variety = "map"; - ancestors = [ "map_ty_base" ]; - nude = true (* Don't inherit {!VisitorsRuntime.iter} *); - concrete = true; - polymorphic = false; - }] -(* TODO: group Bool, Char, etc. in Constant *) - -(** Generic type with regions *) -type 'r gr_ty = 'r region ty [@@deriving show, ord] - -(** *S*ignature types. - - Used in function signatures and type definitions. - *) -type sty = RegionVarId.id gr_ty [@@deriving show, ord] - -(** Type with *R*egions. - - Used to project borrows/loans inside of abstractions, during symbolic - execution. - *) -type rty = RegionId.id gr_ty [@@deriving show, ord] - -(** Type with *E*rased regions. - - Used in function bodies, "regular" value types, etc. - *) -type ety = erased_region ty [@@deriving show, ord] - -type field = { meta : meta; field_name : string option; field_ty : sty } -[@@deriving show] - -type variant = { meta : meta; variant_name : string; fields : field list } -[@@deriving show] - -type type_decl_kind = - | Struct of field list - | Enum of variant list - | Opaque - (** An opaque type: either a local type marked as opaque, or an external type *) -[@@deriving show] - -type type_decl = { - def_id : TypeDeclId.id; - meta : meta; - name : type_name; - region_params : region_var list; - type_params : type_var list; - kind : type_decl_kind; - regions_hierarchy : region_var_groups; - (** Stores the hierarchy between the regions (which regions have the - same lifetime, which lifetime should end before which other lifetime, - etc.) *) -} -[@@deriving show] diff --git a/src/TypesAnalysis.ml b/src/TypesAnalysis.ml deleted file mode 100644 index 60ce5149..00000000 --- a/src/TypesAnalysis.ml +++ /dev/null @@ -1,328 +0,0 @@ -open Types -open Crates - -type subtype_info = { - under_borrow : bool; (** Are we inside a borrow? *) - under_mut_borrow : bool; (** Are we inside a mut borrow? *) -} -[@@deriving show] - -(** See {!type_decl_info} *) -type type_param_info = subtype_info [@@deriving show] - -type expl_info = subtype_info [@@deriving show] - -type type_borrows_info = { - contains_static : bool; - (** Does the type (transitively) contains a static borrow? *) - contains_borrow : bool; - (** Does the type (transitively) contains a borrow? *) - contains_nested_borrows : bool; - (** Does the type (transitively) contains nested borrows? *) - contains_borrow_under_mut : bool; -} -[@@deriving show] - -(** Generic definition *) -type 'p g_type_info = { - borrows_info : type_borrows_info; - (** Various informations about the borrows *) - param_infos : 'p; (** Gives information about the type parameters *) -} -[@@deriving show] - -(** Information about a type definition. *) -type type_decl_info = type_param_info list g_type_info [@@deriving show] - -(** Information about a type. *) -type ty_info = type_borrows_info [@@deriving show] - -(** Helper definition. - - Allows us to factorize code: {!analyze_full_ty} is used both to analyze - type definitions and types. *) -type partial_type_info = type_param_info list option g_type_info -[@@deriving show] - -type type_infos = type_decl_info TypeDeclId.Map.t [@@deriving show] - -let expl_info_init = { under_borrow = false; under_mut_borrow = false } - -let type_borrows_info_init : type_borrows_info = - { - contains_static = false; - contains_borrow = false; - contains_nested_borrows = false; - contains_borrow_under_mut = false; - } - -let initialize_g_type_info (param_infos : 'p) : 'p g_type_info = - { borrows_info = type_borrows_info_init; param_infos } - -let initialize_type_decl_info (def : type_decl) : type_decl_info = - let param_info = { under_borrow = false; under_mut_borrow = false } in - let param_infos = List.map (fun _ -> param_info) def.type_params in - initialize_g_type_info param_infos - -let type_decl_info_to_partial_type_info (info : type_decl_info) : - partial_type_info = - { borrows_info = info.borrows_info; param_infos = Some info.param_infos } - -let partial_type_info_to_type_decl_info (info : partial_type_info) : - type_decl_info = - { - borrows_info = info.borrows_info; - param_infos = Option.get info.param_infos; - } - -let partial_type_info_to_ty_info (info : partial_type_info) : ty_info = - info.borrows_info - -let analyze_full_ty (r_is_static : 'r -> bool) (updated : bool ref) - (infos : type_infos) (ty_info : partial_type_info) (ty : 'r ty) : - partial_type_info = - (* Small utility *) - let check_update_bool (original : bool) (nv : bool) : bool = - if nv && not original then ( - updated := true; - nv) - else original - in - - (* Update a partial_type_info, while registering if we actually performed an update *) - let update_ty_info (ty_info : partial_type_info) - (ty_b_info : type_borrows_info) : partial_type_info = - let original = ty_info.borrows_info in - let contains_static = - check_update_bool original.contains_static ty_b_info.contains_static - in - let contains_borrow = - check_update_bool original.contains_borrow ty_b_info.contains_borrow - in - let contains_nested_borrows = - check_update_bool original.contains_nested_borrows - ty_b_info.contains_nested_borrows - in - let contains_borrow_under_mut = - check_update_bool original.contains_borrow_under_mut - ty_b_info.contains_borrow_under_mut - in - let updated_borrows_info = - { - contains_static; - contains_borrow; - contains_nested_borrows; - contains_borrow_under_mut; - } - in - { ty_info with borrows_info = updated_borrows_info } - in - - (* The recursive function which explores the type *) - let rec analyze (expl_info : expl_info) (ty_info : partial_type_info) - (ty : 'r ty) : partial_type_info = - match ty with - | Bool | Char | Never | Integer _ | Str -> ty_info - | TypeVar var_id -> ( - (* Update the information for the proper parameter, if necessary *) - match ty_info.param_infos with - | None -> ty_info - | Some param_infos -> - let param_info = TypeVarId.nth param_infos var_id in - (* Set [under_borrow] *) - let under_borrow = - check_update_bool param_info.under_borrow expl_info.under_borrow - in - (* Set [under_nested_borrows] *) - let under_mut_borrow = - check_update_bool param_info.under_mut_borrow - expl_info.under_mut_borrow - in - (* Update param_info *) - let param_info = { under_borrow; under_mut_borrow } in - let param_infos = - TypeVarId.update_nth param_infos var_id param_info - in - let param_infos = Some param_infos in - { ty_info with param_infos }) - | Array ty | Slice ty -> - (* Just dive in *) - analyze expl_info ty_info ty - | Ref (r, rty, rkind) -> - (* Update the type info *) - let contains_static = r_is_static r in - let contains_borrow = true in - let contains_nested_borrows = expl_info.under_borrow in - let contains_borrow_under_mut = expl_info.under_mut_borrow in - let ty_b_info = - { - contains_static; - contains_borrow; - contains_nested_borrows; - contains_borrow_under_mut; - } - in - let ty_info = update_ty_info ty_info ty_b_info in - (* Update the exploration info *) - let expl_info = - { - under_borrow = true; - under_mut_borrow = expl_info.under_mut_borrow || rkind = Mut; - } - in - (* Continue exploring *) - analyze expl_info ty_info rty - | Adt ((Tuple | Assumed (Box | Vec | Option)), _, tys) -> - (* Nothing to update: just explore the type parameters *) - List.fold_left - (fun ty_info ty -> analyze expl_info ty_info ty) - ty_info tys - | Adt (AdtId adt_id, regions, tys) -> - (* Lookup the information for this type definition *) - let adt_info = TypeDeclId.Map.find adt_id infos in - (* Update the type info with the information from the adt *) - let ty_info = update_ty_info ty_info adt_info.borrows_info in - (* Check if 'static appears in the region parameters *) - let found_static = List.exists r_is_static regions in - let borrows_info = ty_info.borrows_info in - let borrows_info = - { - borrows_info with - contains_static = - check_update_bool borrows_info.contains_static found_static; - } - in - let ty_info = { ty_info with borrows_info } in - (* For every instantiated type parameter: update the exploration info - * then explore the type *) - let params_tys = List.combine adt_info.param_infos tys in - let ty_info = - List.fold_left - (fun ty_info (param_info, ty) -> - (* Update the type info *) - (* Below: we use only the information which we learn only - * by taking the type parameter into account. *) - let contains_static = false in - let contains_borrow = param_info.under_borrow in - let contains_nested_borrows = - expl_info.under_borrow && param_info.under_borrow - in - let contains_borrow_under_mut = - expl_info.under_mut_borrow && param_info.under_borrow - in - let ty_b_info = - { - contains_static; - contains_borrow; - contains_nested_borrows; - contains_borrow_under_mut; - } - in - let ty_info = update_ty_info ty_info ty_b_info in - (* Update the exploration info *) - let expl_info = - { - under_borrow = - expl_info.under_borrow || param_info.under_borrow; - under_mut_borrow = - expl_info.under_mut_borrow || param_info.under_mut_borrow; - } - in - (* Continue exploring *) - analyze expl_info ty_info ty) - ty_info params_tys - in - (* Return *) - ty_info - in - (* Explore *) - analyze expl_info_init ty_info ty - -let type_decl_is_opaque (d : type_decl) : bool = - match d.kind with Struct _ | Enum _ -> false | Opaque -> true - -let analyze_type_decl (updated : bool ref) (infos : type_infos) - (def : type_decl) : type_infos = - (* We analyze the type declaration only if it is not opaque (we need to explore - * the variants of the ADTs *) - if type_decl_is_opaque def then infos - else - (* Retrieve all the types of all the fields of all the variants *) - let fields_tys : sty list = - match def.kind with - | Struct fields -> List.map (fun f -> f.field_ty) fields - | Enum variants -> - List.concat - (List.map - (fun v -> List.map (fun f -> f.field_ty) v.fields) - variants) - | Opaque -> raise (Failure "unreachable") - in - (* Explore the types and accumulate information *) - let r_is_static r = r = Static in - let type_decl_info = TypeDeclId.Map.find def.def_id infos in - let type_decl_info = type_decl_info_to_partial_type_info type_decl_info in - let type_decl_info = - List.fold_left - (fun type_decl_info ty -> - analyze_full_ty r_is_static updated infos type_decl_info ty) - type_decl_info fields_tys - in - let type_decl_info = partial_type_info_to_type_decl_info type_decl_info in - (* Update the information for the type definition we explored *) - let infos = TypeDeclId.Map.add def.def_id type_decl_info infos in - (* Return *) - infos - -let analyze_type_declaration_group (type_decls : type_decl TypeDeclId.Map.t) - (infos : type_infos) (decl : type_declaration_group) : type_infos = - (* Collect the identifiers used in the declaration group *) - let ids = match decl with NonRec id -> [ id ] | Rec ids -> ids in - (* Retrieve the type definitions *) - let decl_defs = List.map (fun id -> TypeDeclId.Map.find id type_decls) ids in - (* Initialize the type information for the current definitions *) - let infos = - List.fold_left - (fun infos def -> - TypeDeclId.Map.add def.def_id (initialize_type_decl_info def) infos) - infos decl_defs - in - (* Analyze the types - this function simply computes a fixed-point *) - let updated : bool ref = ref false in - let rec analyze (infos : type_infos) : type_infos = - let infos = - List.fold_left - (fun infos def -> analyze_type_decl updated infos def) - infos decl_defs - in - if !updated then ( - updated := false; - analyze infos) - else infos - in - analyze infos - -(** Compute the type information for every *type definition* in a list of - declarations. This type definition information is later used to easily - compute the information of arbitrary types. - - Rk.: pay attention to the difference between type definitions and types! - *) -let analyze_type_declarations (type_decls : type_decl TypeDeclId.Map.t) - (decls : type_declaration_group list) : type_infos = - List.fold_left - (fun infos decl -> analyze_type_declaration_group type_decls infos decl) - TypeDeclId.Map.empty decls - -(** Analyze a type to check whether it contains borrows, etc., provided - we have already analyzed the type definitions in the context. - *) -let analyze_ty (infos : type_infos) (ty : 'r ty) : ty_info = - (* We don't use [updated] but need to give it as parameter *) - let updated = ref false in - (* We don't need to compute whether the type contains 'static or not *) - let r_is_static _ = false in - let ty_info = initialize_g_type_info None in - let ty_info = analyze_full_ty r_is_static updated infos ty_info ty in - (* Convert the ty_info *) - partial_type_info_to_ty_info ty_info diff --git a/src/TypesUtils.ml b/src/TypesUtils.ml deleted file mode 100644 index 7531dd8b..00000000 --- a/src/TypesUtils.ml +++ /dev/null @@ -1,190 +0,0 @@ -open Types -open Utils -module TA = TypesAnalysis - -let type_decl_is_opaque (d : type_decl) : bool = - match d.kind with Struct _ | Enum _ -> false | Opaque -> true - -(** Retrieve the list of fields for the given variant of a {!Types.type_decl}. - - Raises [Invalid_argument] if the arguments are incorrect. - *) -let type_decl_get_fields (def : type_decl) - (opt_variant_id : VariantId.id option) : field list = - match (def.kind, opt_variant_id) with - | Enum variants, Some variant_id -> (VariantId.nth variants variant_id).fields - | Struct fields, None -> fields - | _ -> - let opt_variant_id = - match opt_variant_id with None -> "None" | Some _ -> "Some" - in - raise - (Invalid_argument - ("The variant id should be [Some] if and only if the definition is \ - an enumeration:\n\ - - def: " ^ show_type_decl def ^ "\n- opt_variant_id: " - ^ opt_variant_id)) - -(** Return [true] if a {!Types.ty} is actually [unit] *) -let ty_is_unit (ty : 'r ty) : bool = - match ty with Adt (Tuple, [], []) -> true | _ -> false - -let ty_is_adt (ty : 'r ty) : bool = - match ty with Adt (_, _, _) -> true | _ -> false - -let ty_as_adt (ty : 'r ty) : type_id * 'r list * 'r ty list = - match ty with - | Adt (id, regions, tys) -> (id, regions, tys) - | _ -> failwith "Unreachable" - -let ty_is_custom_adt (ty : 'r ty) : bool = - match ty with Adt (AdtId _, _, _) -> true | _ -> false - -let ty_as_custom_adt (ty : 'r ty) : TypeDeclId.id * 'r list * 'r ty list = - match ty with - | Adt (AdtId id, regions, tys) -> (id, regions, tys) - | _ -> failwith "Unreachable" - -(** The unit type *) -let mk_unit_ty : 'r ty = Adt (Tuple, [], []) - -(** The usize type *) -let mk_usize_ty : 'r ty = Integer Usize - -(** Deconstruct a type of the form [Box] to retrieve the [T] inside *) -let ty_get_box (box_ty : ety) : ety = - match box_ty with - | Adt (Assumed Box, [], [ boxed_ty ]) -> boxed_ty - | _ -> failwith "Not a boxed type" - -(** Deconstruct a type of the form [&T] or [&mut T] to retrieve the [T] (and - the borrow kind, etc.) - *) -let ty_get_ref (ty : 'r ty) : 'r * 'r ty * ref_kind = - match ty with - | Ref (r, ty, ref_kind) -> (r, ty, ref_kind) - | _ -> failwith "Not a ref type" - -let mk_ref_ty (r : 'r) (ty : 'r ty) (ref_kind : ref_kind) : 'r ty = - Ref (r, ty, ref_kind) - -(** Make a box type *) -let mk_box_ty (ty : 'r ty) : 'r ty = Adt (Assumed Box, [], [ ty ]) - -(** Make a vec type *) -let mk_vec_ty (ty : 'r ty) : 'r ty = Adt (Assumed Vec, [], [ ty ]) - -(** Check if a region is in a set of regions *) -let region_in_set (r : RegionId.id region) (rset : RegionId.Set.t) : bool = - match r with Static -> false | Var id -> RegionId.Set.mem id rset - -(** Return the set of regions in an rty *) -let rty_regions (ty : rty) : RegionId.Set.t = - let s = ref RegionId.Set.empty in - let add_region (r : RegionId.id region) = - match r with Static -> () | Var rid -> s := RegionId.Set.add rid !s - in - let obj = - object - inherit [_] iter_ty - method! visit_'r _env r = add_region r - end - in - (* Explore the type *) - obj#visit_ty () ty; - (* Return the set of accumulated regions *) - !s - -let rty_regions_intersect (ty : rty) (regions : RegionId.Set.t) : bool = - let ty_regions = rty_regions ty in - not (RegionId.Set.disjoint ty_regions regions) - -(** Convert an {!Types.ety}, containing no region variables, to an {!Types.rty} - or an {!Types.sty}. - - In practice, it is the identity. - *) -let rec ety_no_regions_to_gr_ty (ty : ety) : 'a gr_ty = - match ty with - | Adt (type_id, regions, tys) -> - assert (regions = []); - Adt (type_id, [], List.map ety_no_regions_to_gr_ty tys) - | TypeVar v -> TypeVar v - | Bool -> Bool - | Char -> Char - | Never -> Never - | Integer int_ty -> Integer int_ty - | Str -> Str - | Array ty -> Array (ety_no_regions_to_gr_ty ty) - | Slice ty -> Slice (ety_no_regions_to_gr_ty ty) - | Ref (_, _, _) -> - failwith - "Can't convert a ref with erased regions to a ref with non-erased \ - regions" - -let ety_no_regions_to_rty (ty : ety) : rty = ety_no_regions_to_gr_ty ty -let ety_no_regions_to_sty (ty : ety) : sty = ety_no_regions_to_gr_ty ty - -(** Retuns true if the type contains borrows. - - Note that we can't simply explore the type and look for regions: sometimes - we erase the lists of regions (by replacing them with [[]] when using {!Types.ety}, - and when a type uses 'static this region doesn't appear in the region parameters. - *) -let ty_has_borrows (infos : TA.type_infos) (ty : 'r ty) : bool = - let info = TA.analyze_ty infos ty in - info.TA.contains_borrow - -(** Retuns true if the type contains nested borrows. - - Note that we can't simply explore the type and look for regions: sometimes - we erase the lists of regions (by replacing them with [[]] when using {!Types.ety}, - and when a type uses 'static this region doesn't appear in the region parameters. - *) -let ty_has_nested_borrows (infos : TA.type_infos) (ty : 'r ty) : bool = - let info = TA.analyze_ty infos ty in - info.TA.contains_nested_borrows - -(** Retuns true if the type contains a borrow under a mutable borrow *) -let ty_has_borrow_under_mut (infos : TA.type_infos) (ty : 'r ty) : bool = - let info = TA.analyze_ty infos ty in - info.TA.contains_borrow_under_mut - -(** Check if a {!Types.ty} contains regions from a given set *) -let ty_has_regions_in_set (rset : RegionId.Set.t) (ty : rty) : bool = - let obj = - object - inherit [_] iter_ty as super - - method! visit_Adt env type_id regions tys = - List.iter (fun r -> if region_in_set r rset then raise Found) regions; - super#visit_Adt env type_id regions tys - - method! visit_Ref env r ty rkind = - if region_in_set r rset then raise Found - else super#visit_Ref env r ty rkind - end - in - try - obj#visit_ty () ty; - false - with Found -> true - -(** Return true if a type is "primitively copyable". - * - * "primitively copyable" means that copying instances of this type doesn't - * require calling dedicated functions defined through the Copy trait. It - * is the case for types like integers, shared borrows, etc. - * - * Generally, ADTs are not copyable. However, some of the primitive ADTs are - * like `Option`. - *) -let rec ty_is_primitively_copyable (ty : 'r ty) : bool = - match ty with - | Adt (Assumed Option, _, tys) -> List.for_all ty_is_primitively_copyable tys - | Adt ((AdtId _ | Assumed (Box | Vec)), _, _) -> false - | Adt (Tuple, _, tys) -> List.for_all ty_is_primitively_copyable tys - | TypeVar _ | Never | Str | Array _ | Slice _ -> false - | Bool | Char | Integer _ -> true - | Ref (_, _, Mut) -> false - | Ref (_, _, Shared) -> true diff --git a/src/Utils.ml b/src/Utils.ml deleted file mode 100644 index a285e869..00000000 --- a/src/Utils.ml +++ /dev/null @@ -1,6 +0,0 @@ -exception Found -(** Utility exception - - When looking for something while exploring a term, it can be easier to - just throw an exception to signal we found what we were looking for. - *) diff --git a/src/Values.ml b/src/Values.ml deleted file mode 100644 index e404f40d..00000000 --- a/src/Values.ml +++ /dev/null @@ -1,844 +0,0 @@ -open Identifiers -open Types - -(* TODO: I often write "abstract" (value, borrow content, etc.) while I should - * write "abstraction" (because those values are not abstract, they simply are - * inside abstractions) *) - -module VarId = IdGen () -module BorrowId = IdGen () -module SymbolicValueId = IdGen () -module AbstractionId = IdGen () -module FunCallId = IdGen () - -(** A variable *) - -type big_int = Z.t - -let big_int_of_yojson (json : Yojson.Safe.t) : (big_int, string) result = - match json with - | `Int i -> Ok (Z.of_int i) - | `Intlit is -> Ok (Z.of_string is) - | _ -> Error "not an integer or an integer literal" - -let big_int_to_yojson (i : big_int) = `Intlit (Z.to_string i) - -let pp_big_int (fmt : Format.formatter) (bi : big_int) : unit = - Format.pp_print_string fmt (Z.to_string bi) - -let show_big_int (bi : big_int) : string = Z.to_string bi - -(** A scalar value - - Note that we use unbounded integers everywhere. - We then harcode the boundaries for the different types. - *) -type scalar_value = { value : big_int; int_ty : integer_type } [@@deriving show] - -(** A constant value *) -type constant_value = - | Scalar of scalar_value - | Bool of bool - | Char of char - | String of string -[@@deriving show] - -(** The kind of a symbolic value, which precises how the value was generated *) -type sv_kind = - | FunCallRet (** The value is the return value of a function call *) - | FunCallGivenBack - (** The value is a borrowed value given back by an abstraction - (happens when giving a borrow to a function: when the abstraction - introduced to model the function call ends we reintroduce a symbolic - value in the context for the value modified by the abstraction through - the borrow). - *) - | SynthInput - (** The value is an input value of the function whose body we are - currently synthesizing. - *) - | SynthRetGivenBack - (** The value is a borrowed value that the function whose body we are - synthesizing returned, and which was given back because we ended - one of the lifetimes of this function (we do this to synthesize - the backward functions). - *) - | SynthInputGivenBack - (** The value was given back upon ending one of the input abstractions *) - | Global (** The value is a global *) -[@@deriving show] - -(** A symbolic value *) -type symbolic_value = { - sv_kind : sv_kind; - sv_id : SymbolicValueId.id; - sv_ty : rty; -} -[@@deriving show] - -(** Ancestor for {!typed_value} iter visitor *) -class ['self] iter_typed_value_base = - object (_self : 'self) - inherit [_] VisitorsRuntime.iter - method visit_constant_value : 'env -> constant_value -> unit = fun _ _ -> () - method visit_erased_region : 'env -> erased_region -> unit = fun _ _ -> () - method visit_symbolic_value : 'env -> symbolic_value -> unit = fun _ _ -> () - method visit_ety : 'env -> ety -> unit = fun _ _ -> () - end - -(** Ancestor for {!typed_value} map visitor for *) -class ['self] map_typed_value_base = - object (_self : 'self) - inherit [_] VisitorsRuntime.map - - method visit_constant_value : 'env -> constant_value -> constant_value = - fun _ cv -> cv - - method visit_erased_region : 'env -> erased_region -> erased_region = - fun _ r -> r - - method visit_symbolic_value : 'env -> symbolic_value -> symbolic_value = - fun _ sv -> sv - - method visit_ety : 'env -> ety -> ety = fun _ ty -> ty - end - -(** An untyped value, used in the environments *) -type value = - | Concrete of constant_value (** Concrete (non-symbolic) value *) - | Adt of adt_value (** Enumerations and structures *) - | Bottom (** No value (uninitialized or moved value) *) - | Borrow of borrow_content (** A borrowed value *) - | Loan of loan_content (** A loaned value *) - | Symbolic of symbolic_value - (** Borrow projector over a symbolic value. - - Note that contrary to the abstraction-values case, symbolic values - appearing in regular values are interpreted as *borrow* projectors, - they can never be *loan* projectors. - *) - -and adt_value = { - variant_id : (VariantId.id option[@opaque]); - field_values : typed_value list; -} - -and borrow_content = - | SharedBorrow of mvalue * (BorrowId.id[@opaque]) - (** A shared borrow. - - We remember the shared value which was borrowed as a meta value. - This is necessary for synthesis: upon translating to "pure" values, - we can't perform any lookup because we don't have an environment - anymore. Note that it is ok to keep the shared value and copy - the shared value this way, because shared values are immutable - for as long as they are shared (i.e., as long as we can use the - shared borrow). - *) - | MutBorrow of (BorrowId.id[@opaque]) * typed_value - (** A mutably borrowed value. *) - | InactivatedMutBorrow of mvalue * (BorrowId.id[@opaque]) - (** An inactivated mut borrow. - - This is used to model {{: https://rustc-dev-guide.rust-lang.org/borrow_check/two_phase_borrows.html} two-phase borrows}. - When evaluating a two-phase mutable borrow, we first introduce an inactivated - borrow which behaves like a shared borrow, until the moment we actually *use* - the borrow: at this point, we end all the other shared borrows (or inactivated - borrows - though there shouldn't be any other inactivated borrows if the program - is well typed) of this value and replace the inactivated borrow with a - mutable borrow. - - A simple use case of two-phase borrows: - {[ - let mut v = Vec::new(); - v.push(v.len()); - ]} - - This gets desugared to (something similar to) the following MIR: - {[ - v = Vec::new(); - v1 = &mut v; - v2 = &v; // We need this borrow, but v has already been mutably borrowed! - l = Vec::len(move v2); - Vec::push(move v1, move l); // In practice, v1 gets activated only here - ]} - - The meta-value is used for the same purposes as with shared borrows, - at the exception that in case of inactivated borrows it is not - *necessary* for the synthesis: we keep it only as meta-information. - To be more precise: - - when generating the synthesized program, we may need to convert - shared borrows to pure values - - we never need to do so for inactivated borrows: such borrows must - be activated at the moment we use them (meaning we convert a *mutable* - borrow to a pure value). However, we save meta-data about the assignments, - which is used to make the code cleaner: when generating this meta-data, - we may need to convert inactivated borrows to pure values, in which - situation we convert the meta-value we stored in the inactivated - borrow. - *) - -and loan_content = - | SharedLoan of (BorrowId.Set.t[@opaque]) * typed_value - | MutLoan of (BorrowId.id[@opaque]) - (** TODO: we might want to add a set of borrow ids (useful for inactivated - borrows, and extremely useful when giving shared values to abstractions). - *) - -(** "Meta"-value: information we store for the synthesis. - - Note that we never automatically visit the meta-values with the - visitors: they really are meta information, and shouldn't be considered - as part of the environment during a symbolic execution. - - TODO: we may want to create wrappers, to prevent accidently mixing meta - values and regular values. - *) -and mvalue = typed_value - -(** "Regular" typed value (we map variables to typed values) *) -and typed_value = { value : value; ty : ety } -[@@deriving - show, - visitors - { - name = "iter_typed_value_visit_mvalue"; - variety = "iter"; - ancestors = [ "iter_typed_value_base" ]; - nude = true (* Don't inherit {!VisitorsRuntime.iter} *); - concrete = true; - }, - visitors - { - name = "map_typed_value_visit_mvalue"; - variety = "map"; - ancestors = [ "map_typed_value_base" ]; - nude = true (* Don't inherit {!VisitorsRuntime.iter} *); - concrete = true; - }] - -(** We have to override the {!iter_typed_value_visit_mvalue.visit_mvalue} method, - to ignore meta-values *) -class ['self] iter_typed_value = - object (_self : 'self) - inherit [_] iter_typed_value_visit_mvalue - method! visit_mvalue : 'env -> mvalue -> unit = fun _ _ -> () - end - -(** We have to override the {!iter_typed_value_visit_mvalue.visit_mvalue} method, - to ignore meta-values *) -class ['self] map_typed_value = - object (_self : 'self) - inherit [_] map_typed_value_visit_mvalue - method! visit_mvalue : 'env -> mvalue -> mvalue = fun _ x -> x - end - -(** "Meta"-symbolic value. - - See the explanations for {!mvalue} - - TODO: we may want to create wrappers, to prevent mixing meta values - and regular values. - *) -type msymbolic_value = symbolic_value [@@deriving show] - -(** When giving shared borrows to functions (i.e., inserting shared borrows inside - abstractions) we need to reborrow the shared values. When doing so, we lookup - the shared values and apply some special projections to the shared value - (until we can't go further, i.e., we find symbolic values which may get - expanded upon reading them later), which don't generate avalues but - sets of borrow ids and symbolic values. - - Note that as shared values can't get modified it is ok to forget the - structure of the values we projected, and only keep the set of borrows - (and symbolic values). - - TODO: we may actually need to remember the structure, in order to know - which borrows are inside which other borrows... -*) -type abstract_shared_borrow = - | AsbBorrow of (BorrowId.id[@opaque]) - | AsbProjReborrows of (symbolic_value[@opaque]) * (rty[@opaque]) -[@@deriving show] - -(** A set of abstract shared borrows *) -type abstract_shared_borrows = abstract_shared_borrow list [@@deriving show] - -(** Ancestor for {!aproj} iter visitor *) -class ['self] iter_aproj_base = - object (_self : 'self) - inherit [_] iter_typed_value - method visit_rty : 'env -> rty -> unit = fun _ _ -> () - - method visit_msymbolic_value : 'env -> msymbolic_value -> unit = - fun _ _ -> () - end - -(** Ancestor for {!aproj} map visitor *) -class ['self] map_aproj_base = - object (_self : 'self) - inherit [_] map_typed_value - method visit_rty : 'env -> rty -> rty = fun _ ty -> ty - - method visit_msymbolic_value : 'env -> msymbolic_value -> msymbolic_value = - fun _ m -> m - end - -type aproj = - | AProjLoans of symbolic_value * (msymbolic_value * aproj) list - (** A projector of loans over a symbolic value. - - Note that the borrows of a symbolic value may be spread between - different abstractions, meaning that the projector of loans might - receive *several* (symbolic) given back values. - - This is the case in the following example: - {[ - fn f<'a> (...) -> (&'a mut u32, &'a mut u32); - fn g<'b, 'c>(p : (&'b mut u32, &'c mut u32)); - - let p = f(...); - g(move p); - - // Symbolic context after the call to g: - // abs'a {'a} { [s@0 <: (&'a mut u32, &'a mut u32)] } - // - // abs'b {'b} { (s@0 <: (&'b mut u32, &'c mut u32)) } - // abs'c {'c} { (s@0 <: (&'b mut u32, &'c mut u32)) } - ]} - - Upon evaluating the call to [f], we introduce a symbolic value [s@0] - and a projector of loans (projector loans from the region 'c). - This projector will later receive two given back values: one for - 'a and one for 'b. - - We accumulate those values in the list of projections (note that - the meta value stores the value which was given back). - - We can later end the projector of loans if [s@0] is not referenced - anywhere in the context below a projector of borrows which intersects - this projector of loans. - *) - | AProjBorrows of symbolic_value * rty - (** Note that an AProjBorrows only operates on a value which is not below - a shared loan: under a shared loan, we use {!abstract_shared_borrow}. - - Also note that once given to a borrow projection, a symbolic value - can't get updated/expanded: this means that we don't need to save - any meta-value here. - *) - | AEndedProjLoans of msymbolic_value * (msymbolic_value * aproj) list - (** An ended projector of loans over a symbolic value. - - See the explanations for {!AProjLoans} - - Note that we keep the original symbolic value as a meta-value. - *) - | AEndedProjBorrows of msymbolic_value - (** The only purpose of {!AEndedProjBorrows} is to store, for synthesis - purposes, the symbolic value which was generated and given back upon - ending the borrow. - *) - | AIgnoredProjBorrows -[@@deriving - show, - visitors - { - name = "iter_aproj"; - variety = "iter"; - ancestors = [ "iter_aproj_base" ]; - nude = true (* Don't inherit {!VisitorsRuntime.iter} *); - concrete = true; - }, - visitors - { - name = "map_aproj"; - variety = "map"; - ancestors = [ "map_aproj_base" ]; - nude = true (* Don't inherit {!VisitorsRuntime.iter} *); - concrete = true; - }] - -type region = RegionVarId.id Types.region [@@deriving show] - -(** Ancestor for {!typed_avalue} iter visitor *) -class ['self] iter_typed_avalue_base = - object (_self : 'self) - inherit [_] iter_aproj - method visit_id : 'env -> BorrowId.id -> unit = fun _ _ -> () - method visit_region : 'env -> region -> unit = fun _ _ -> () - - method visit_abstract_shared_borrows - : 'env -> abstract_shared_borrows -> unit = - fun _ _ -> () - end - -(** Ancestor for {!typed_avalue} map visitor *) -class ['self] map_typed_avalue_base = - object (_self : 'self) - inherit [_] map_aproj - method visit_id : 'env -> BorrowId.id -> BorrowId.id = fun _ id -> id - method visit_region : 'env -> region -> region = fun _ r -> r - - method visit_abstract_shared_borrows - : 'env -> abstract_shared_borrows -> abstract_shared_borrows = - fun _ asb -> asb - end - -(** Abstraction values are used inside of abstractions to properly model - borrowing relations introduced by function calls. - - When calling a function, we lose information about the borrow graph: - part of it is thus "abstracted" away. -*) -type avalue = - | AConcrete of constant_value - (** TODO: remove. We actually don't use that for the synthesis, but the - meta-values. - - Note that this case is not used in the projections to keep track of the - borrow graph (because there are no borrows in "concrete" values!) but - to correctly instantiate the backward functions (we may give back some - values at different moments: we need to remember what those values were - precisely). Also note that even though avalues and values are not the - same, once values are projected to avalues, those avalues still have - the structure of the original values (this is necessary, again, to - correctly instantiate the backward functions) - *) - | AAdt of adt_avalue - | ABottom - | ALoan of aloan_content - | ABorrow of aborrow_content - | ASymbolic of aproj - | AIgnored - (** A value which doesn't contain borrows, or which borrows we - don't own and thus ignore *) - -and adt_avalue = { - variant_id : (VariantId.id option[@opaque]); - field_values : typed_avalue list; -} - -(** A loan content as stored in an abstraction. - - Note that the children avalues are independent of the parent avalues. - For instance, the child avalue contained in an {!AMutLoan} will likely - contain other, independent loans. - Keeping track of the hierarchy is not necessary to maintain the borrow graph - (which is the primary role of the abstractions), but it is necessary - to properly instantiate the backward functions when generating the pure - translation. -*) -and aloan_content = - | AMutLoan of (BorrowId.id[@opaque]) * typed_avalue - (** A mutable loan owned by an abstraction. - - Example: - ======== - {[ - fn f<'a>(...) -> &'a mut &'a mut u32; - - let px = f(...); - ]} - - We get (after some symbolic exansion): - {[ - abs0 { - a_mut_loan l0 (a_mut_loan l1) - } - px -> mut_borrow l0 (mut_borrow @s1) - ]} - *) - | ASharedLoan of (BorrowId.Set.t[@opaque]) * typed_value * typed_avalue - (** A shared loan owned by an abstraction. - - Example: - ======== - {[ - fn f<'a>(...) -> &'a u32; - - let px = f(...); - ]} - - We get: - {[ - abs0 { a_shared_loan {l0} @s0 ⊥ } - px -> shared_loan l0 - ]} - *) - | AEndedMutLoan of { - child : typed_avalue; - given_back : typed_avalue; - given_back_meta : mvalue; - } - (** An ended mutable loan in an abstraction. - We need it because abstractions must keep track of the values - we gave back to them, so that we can correctly instantiate - backward functions. - - Rk.: *DO NOT* use [visit_AEndedMutLoan]. If we update the order of - the arguments and you forget to swap them at the level of - [visit_AEndedMutLoan], you will not notice it. - - Example: - ======== - {[ - abs0 { a_mut_loan l0 ⊥ } - x -> mut_borrow l0 (U32 3) - ]} - - After ending [l0]: - - {[ - abs0 { a_ended_mut_loan { given_back = U32 3; child = ⊥; } - x -> ⊥ - ]} - *) - | AEndedSharedLoan of typed_value * typed_avalue - (** Similar to {!AEndedMutLoan} but in this case there are no avalues to - give back. We keep the shared value because it now behaves as a - "regular" value (which contains borrows we might want to end...). - *) - | AIgnoredMutLoan of (BorrowId.id[@opaque]) * typed_avalue - (** An ignored mutable loan. - - We need to keep track of ignored mutable loans, because we may have - to apply projections on the values given back to those loans (say - you have a borrow of type [&'a mut &'b mut], in the abstraction 'b, - the outer loan is ignored, however you need to keep track of it so - that when ending the borrow corresponding to 'a you can correctly - project on the inner value). - - Example: - ======== - {[ - fn f<'a,'b>(...) -> &'a mut &'b mut u32; - let x = f(...); - - > abs'a { a_mut_loan l0 (a_ignored_mut_loan l1 ⊥) } - > abs'b { a_ignored_mut_loan l0 (a_mut_loan l1 ⊥) } - > x -> mut_borrow l0 (mut_borrow l1 @s1) - ]} - *) - | AEndedIgnoredMutLoan of { - child : typed_avalue; - given_back : typed_avalue; - given_back_meta : mvalue; - } - (** Similar to {!AEndedMutLoan}, for ignored loans. - - Rk.: *DO NOT* use [visit_AEndedIgnoredMutLoan]. - See the comment for {!AEndedMutLoan}. - *) - | AIgnoredSharedLoan of typed_avalue - (** An ignored shared loan. - - Example: - ======== - {[ - fn f<'a,'b>(...) -> &'a &'b u32; - let x = f(...); - - > abs'a { a_shared_loan {l0} (shared_borrow l1) (a_ignored_shared_loan ⊥) } - > abs'b { a_ignored_shared_loan (a_shared_loan {l1} @s1 ⊥) } - > x -> shared_borrow l0 - ]} - *) - -(** Note that when a borrow content is ended, it is replaced by ⊥ (while - we need to track ended loans more precisely, especially because of their - children values). - - Note that contrary to {!aloan_content}, here the children avalues are - not independent of the parent avalues. For instance, a value - [AMutBorrow (_, AMutBorrow (_, ...)] (ignoring the types) really is - to be seen like a [mut_borrow ... (mut_borrow ...)]. - - TODO: be more precise about the ignored borrows (keep track of the borrow - ids)? -*) -and aborrow_content = - | AMutBorrow of mvalue * (BorrowId.id[@opaque]) * typed_avalue - (** A mutable borrow owned by an abstraction. - - Is used when an abstraction "consumes" borrows, when giving borrows - as arguments to a function. - - Example: - ======== - {[ - fn f<'a>(px : &'a mut u32); - - > x -> mut_loan l0 - > px -> mut_borrow l0 (U32 0) - - f(move px); - - > x -> mut_loan l0 - > px -> ⊥ - > abs0 { a_mut_borrow l0 (U32 0) } - ]} - - The meta-value stores the initial value on which the projector was - applied, which reduced to this mut borrow. This meta-information - is only used for the synthesis. - TODO: do we really use it actually? - *) - | ASharedBorrow of (BorrowId.id[@opaque]) - (** A shared borrow owned by an abstraction. - - Example: - ======== - {[ - fn f<'a>(px : &'a u32); - - > x -> shared_loan {l0} (U32 0) - > px -> shared_borrow l0 - - f(move px); - - > x -> shared_loan {l0} (U32 0) - > px -> ⊥ - > abs0 { a_shared_borrow l0 } - ]} - *) - | AIgnoredMutBorrow of BorrowId.id option * typed_avalue - (** An ignored mutable borrow. - - We need to keep track of ignored mut borrows because when ending such - borrows, we need to project the loans of the given back value to - insert them in the proper abstractions. - - Note that we need to do so only for borrows consumed by parent - abstractions (hence the optional borrow id). - - TODO: the below explanations are obsolete - - Example: - ======== - {[ - fn f<'a,'b>(ppx : &'a mut &'b mut u32); - - > x -> mut_loan l0 - > px -> mut_loan l1 - > ppx -> mut_borrow l1 (mut_borrow l0 (U32 0)) - - f(move ppx); - - > x -> mut_loan l0 - > px -> mut_loan l1 - > ppx -> ⊥ - > abs'a { a_mut_borrow l1 (a_ignored_mut_borrow None (U32 0)) } // TODO: duplication - > abs'b {parents={abs'a}} { a_ignored_mut_borrow (Some l1) (a_mut_borrow l0 (U32 0)) } - - ... // abs'a ends - - > x -> mut_loan l0 - > px -> @s0 - > ppx -> ⊥ - > abs'b { - > a_ended_ignored_mut_borrow (a_proj_loans (@s0 <: &'b mut u32)) // <-- loan projector - > (a_mut_borrow l0 (U32 0)) - > } - - ... // [@s0] gets expanded to [&mut l2 @s1] - - > x -> mut_loan l0 - > px -> &mut l2 @s1 - > ppx -> ⊥ - > abs'b { - > a_ended_ignored_mut_borrow (a_mut_loan l2) // <-- loan l2 is here - > (a_mut_borrow l0 (U32 0)) - > } - - ]} - - Note that we could use AIgnoredMutLoan in the case the borrow id is not - None, which would allow us to simplify the rules (to not have rules - to specifically handle the case of AIgnoredMutBorrow with Some borrow - id) and also remove the AEndedIgnoredMutBorrow variant. - For now, the rules are implemented and it allows us to make the avalues - more precise and clearer, so we will keep it that way. - - TODO: this is annoying, we are duplicating information. Maybe we - could introduce an "Ignored" value? We have to pay attention to - two things: - - introducing ⊥ when ignoring a value is not always possible, because - we check whether the borrowed value contains ⊥ when giving back a - borrowed value (if it is the case we give back ⊥, otherwise we - introduce a symbolic value). This is necessary when ending nested - borrows with the same lifetime: when ending the inner borrow we - actually give back a value, however when ending the outer borrow - we need to give back ⊥. - TODO: actually we don't do that anymore, we check if the borrowed - avalue contains ended regions (which is cleaner and more robust). - - we may need to remember the precise values given to the - abstraction so that we can properly call the backward functions - when generating the pure translation. - *) - | AEndedMutBorrow of msymbolic_value * typed_avalue - (** The sole purpose of {!AEndedMutBorrow} is to store the (symbolic) value - that we gave back as a meta-value, to help with the synthesis. - - We also remember the child {!avalue} because this structural information - is useful for the synthesis (but not for the symbolic execution): - in practice the child value should only contain ended borrows, ignored - values, bottom values, etc. - *) - | AEndedSharedBorrow - (** We don't really need {!AEndedSharedBorrow}: we simply want to be - precise, and not insert ⊥ when ending borrows. - *) - | AEndedIgnoredMutBorrow of { - child : typed_avalue; - given_back_loans_proj : typed_avalue; - given_back_meta : msymbolic_value; - (** [given_back_meta] is used to store the (symbolic) value we gave back - upon ending the borrow. - - Rk.: *DO NOT* use [visit_AEndedIgnoredMutLoan]. - See the comment for {!AEndedMutLoan}. - *) - } (** See the explanations for {!AIgnoredMutBorrow} *) - | AProjSharedBorrow of abstract_shared_borrows - (** A projected shared borrow. - - When giving shared borrows as arguments to function calls, we - introduce new borrows to keep track of the fact that the function - might reborrow values inside. Note that as shared values are immutable, - we don't really need to remember the structure of the shared values. - - Example: - ======== - Below, when calling [f], we need to introduce one shared borrow per - borrow in the argument. - {[ - fn f<'a,'b>(pppx : &'a &'b &'c mut u32); - - > x -> mut_loan l0 - > px -> shared_loan {l1} (mut_borrow l0 (U32 0)) - > ppx -> shared_loan {l2} (shared_borrow l1) - > pppx -> shared_borrow l2 - - f(move pppx); - - > x -> mut_loan l0 - > px -> shared_loan {l1, l3, l4} (mut_borrow l0 (U32 0)) - > ppx -> shared_loan {l2} (shared_borrow l1) - > pppx -> ⊥ - > abs'a { a_proj_shared_borrow {l2} } - > abs'b { a_proj_shared_borrow {l3} } // l3 reborrows l1 - > abs'c { a_proj_shared_borrow {l4} } // l4 reborrows l0 - ]} - *) - -(* TODO: the type of avalues doesn't make sense for loan avalues: they currently - are typed as [& (mut) T] instead of [T]... -*) -and typed_avalue = { value : avalue; ty : rty } -[@@deriving - show, - visitors - { - name = "iter_typed_avalue"; - variety = "iter"; - ancestors = [ "iter_typed_avalue_base" ]; - nude = true (* Don't inherit {!VisitorsRuntime.iter} *); - concrete = true; - }, - visitors - { - name = "map_typed_avalue"; - variety = "map"; - ancestors = [ "map_typed_avalue_base" ]; - nude = true (* Don't inherit {!VisitorsRuntime.iter} *); - concrete = true; - }] - -(** The kind of an abstraction, which keeps track of its origin *) -type abs_kind = - | FunCall (** The abstraction was introduced because of a function call *) - | SynthInput - (** The abstraction keeps track of the input values of the function - we are currently synthesizing. *) - | SynthRet - (** The abstraction "absorbed" the value returned by the function we - are currently synthesizing *) -[@@deriving show] - -(** Abstractions model the parts in the borrow graph where the borrowing relations - have been abstracted because of a function call. - - In order to model the relations between the borrows, we use "abstraction values", - which are a special kind of value. -*) -type abs = { - abs_id : (AbstractionId.id[@opaque]); - call_id : (FunCallId.id[@opaque]); - (** The identifier of the function call which introduced this - abstraction. This is not used by the symbolic execution: - this is only used for pretty-printing and debugging, in the - symbolic AST, generated by the symbolic execution. - *) - back_id : (RegionGroupId.id[@opaque]); - (** The region group id to which this abstraction is linked. - - In most situations, it gives the id of the backward function (hence - the name), but it is a bit more subtle in the case of synth input - and synth ret abstractions. - - This is not used by the symbolic execution: it is a utility for - the symbolic AST, generated by the symbolic execution. - *) - kind : (abs_kind[@opaque]); - can_end : (bool[@opaque]); - (** Controls whether the region can be ended or not. - - This allows to "pin" some regions, and is useful when generating - backward functions. - - For instance, if we have: [fn f<'a, 'b>(...) -> (&'a mut T, &'b mut T)], - when generating the backward function for 'a, we have to make sure we - don't need to end the return region for 'b (if it is the case, it means - the function doesn't borrow check). - *) - parents : (AbstractionId.Set.t[@opaque]); (** The parent abstractions *) - original_parents : (AbstractionId.id list[@opaque]); - (** The original list of parents, ordered. This is used for synthesis. *) - regions : (RegionId.Set.t[@opaque]); (** Regions owned by this abstraction *) - ancestors_regions : (RegionId.Set.t[@opaque]); - (** Union of the regions owned by this abstraction's ancestors (not - including the regions of this abstraction itself) *) - avalues : typed_avalue list; (** The values in this abstraction *) -} -[@@deriving - show, - visitors - { - name = "iter_abs"; - variety = "iter"; - ancestors = [ "iter_typed_avalue" ]; - nude = true (* Don't inherit {!VisitorsRuntime.iter} *); - concrete = true; - }, - visitors - { - name = "map_abs"; - variety = "map"; - ancestors = [ "map_typed_avalue" ]; - nude = true (* Don't inherit {!VisitorsRuntime.iter} *); - concrete = true; - }] - -(** A symbolic expansion - - A symbolic expansion doesn't represent a value, but rather an operation - that we apply to values. - - TODO: this should rather be name "expanded_symbolic" - *) -type symbolic_expansion = - | SeConcrete of constant_value - | SeAdt of (VariantId.id option * symbolic_value list) - | SeMutRef of BorrowId.id * symbolic_value - | SeSharedRef of BorrowId.Set.t * symbolic_value diff --git a/src/ValuesUtils.ml b/src/ValuesUtils.ml deleted file mode 100644 index 72d7abe0..00000000 --- a/src/ValuesUtils.ml +++ /dev/null @@ -1,121 +0,0 @@ -open Utils -open TypesUtils -open Types -open Values -module TA = TypesAnalysis - -(** Utility exception *) -exception FoundSymbolicValue of symbolic_value - -let mk_unit_value : typed_value = - { value = Adt { variant_id = None; field_values = [] }; ty = mk_unit_ty } - -let mk_typed_value (ty : ety) (value : value) : typed_value = { value; ty } -let mk_bottom (ty : ety) : typed_value = { value = Bottom; ty } - -(** Box a value *) -let mk_box_value (v : typed_value) : typed_value = - let box_ty = mk_box_ty v.ty in - let box_v = Adt { variant_id = None; field_values = [ v ] } in - mk_typed_value box_ty box_v - -let is_bottom (v : value) : bool = match v with Bottom -> true | _ -> false - -let is_symbolic (v : value) : bool = - match v with Symbolic _ -> true | _ -> false - -let as_symbolic (v : value) : symbolic_value = - match v with Symbolic s -> s | _ -> failwith "Unexpected" - -let as_mut_borrow (v : typed_value) : BorrowId.id * typed_value = - match v.value with - | Borrow (MutBorrow (bid, bv)) -> (bid, bv) - | _ -> failwith "Unexpected" - -(** Check if a value contains a borrow *) -let borrows_in_value (v : typed_value) : bool = - let obj = - object - inherit [_] iter_typed_value - method! visit_borrow_content _env _ = raise Found - end - in - (* We use exceptions *) - try - obj#visit_typed_value () v; - false - with Found -> true - -(** Check if a value contains inactivated mutable borrows *) -let inactivated_in_value (v : typed_value) : bool = - let obj = - object - inherit [_] iter_typed_value - method! visit_InactivatedMutBorrow _env _ = raise Found - end - in - (* We use exceptions *) - try - obj#visit_typed_value () v; - false - with Found -> true - -(** Check if a value contains a loan *) -let loans_in_value (v : typed_value) : bool = - let obj = - object - inherit [_] iter_typed_value - method! visit_loan_content _env _ = raise Found - end - in - (* We use exceptions *) - try - obj#visit_typed_value () v; - false - with Found -> true - -(** Check if a value contains outer loans (i.e., loans which are not in borrwed - values. *) -let outer_loans_in_value (v : typed_value) : bool = - let obj = - object - inherit [_] iter_typed_value - method! visit_loan_content _env _ = raise Found - method! visit_borrow_content _ _ = () - end - in - (* We use exceptions *) - try - obj#visit_typed_value () v; - false - with Found -> true - -let find_first_primitively_copyable_sv_with_borrows (type_infos : TA.type_infos) - (v : typed_value) : symbolic_value option = - (* The visitor *) - let obj = - object - inherit [_] iter_typed_value - - method! visit_Symbolic _ sv = - let ty = sv.sv_ty in - if ty_is_primitively_copyable ty && ty_has_borrows type_infos ty then - raise (FoundSymbolicValue sv) - else () - end - in - (* Small helper *) - try - obj#visit_typed_value () v; - None - with FoundSymbolicValue sv -> Some sv - -(** Strip the outer shared loans in a value. - Ex.: - [shared_loan {l0, l1} (3 : u32, shared_loan {l2} (4 : u32))] ~~> - [(3 : u32, shared_loan {l2} (4 : u32))] - *) -let rec value_strip_shared_loans (v : typed_value) : typed_value = - match v.value with - | Loan (SharedLoan (_, v')) -> value_strip_shared_loans v' - | _ -> v diff --git a/src/driver.ml b/src/driver.ml deleted file mode 100644 index ae9d238a..00000000 --- a/src/driver.ml +++ /dev/null @@ -1,208 +0,0 @@ -open Aeneas.LlbcOfJson -open Aeneas.Logging -open Aeneas.Print -module T = Aeneas.Types -module A = Aeneas.LlbcAst -module I = Aeneas.Interpreter -module EL = Easy_logging.Logging -module TA = Aeneas.TypesAnalysis -module Micro = Aeneas.PureMicroPasses -module Print = Aeneas.Print -module PrePasses = Aeneas.PrePasses -module Translate = Aeneas.Translate - -(* This is necessary to have a backtrace when raising exceptions - for some - * reason, the -g option doesn't work. - * TODO: run with OCAMLRUNPARAM=b=1? *) -let () = Printexc.record_backtrace true - -let usage = - Printf.sprintf - {|Aeneas: verification of Rust programs by translation to pure lambda calculus - -Usage: %s [OPTIONS] FILE -|} - Sys.argv.(0) - -let () = - (* Measure start time *) - let start_time = Unix.gettimeofday () in - - (* Read the command line arguments *) - let dest_dir = ref "" in - let decompose_monads = ref false in - let unfold_monads = ref true in - let filter_useless_calls = ref true in - let filter_useless_functions = ref true in - let test_units = ref false in - let test_trans_units = ref false in - let no_decreases_clauses = ref false in - let no_state = ref false in - let template_decreases_clauses = ref false in - let no_split_files = ref false in - let no_check_inv = ref false in - - let spec = - [ - ("-dest", Arg.Set_string dest_dir, " Specify the output directory"); - ( "-decompose-monads", - Arg.Set decompose_monads, - " Decompose the monadic let-bindings.\n\n\ - \ Introduces a temporary variable which is later decomposed,\n\ - \ when the pattern on the left of the monadic let is not a \n\ - \ variable.\n\ - \ \n\ - \ Example:\n\ - \ `(x, y) <-- f (); ...` ~~>\n\ - \ `tmp <-- f (); let (x, y) = tmp in ...`\n\ - \ " ); - ( "-unfold-monads", - Arg.Set unfold_monads, - " Unfold the monadic let-bindings to matches" ); - ( "-filter-useless-calls", - Arg.Set filter_useless_calls, - " Filter the useless function calls, when possible" ); - ( "-filter-useless-funs", - Arg.Set filter_useless_functions, - " Filter the useless forward/backward functions" ); - ( "-test-units", - Arg.Set test_units, - " Test the unit functions with the concrete interpreter" ); - ( "-test-trans-units", - Arg.Set test_trans_units, - " Test the translated unit functions with the target theorem\n\ - \ prover's normalizer" ); - ( "-no-decreases-clauses", - Arg.Set no_decreases_clauses, - " Do not add decrease clauses to the recursive definitions" ); - ( "-no-state", - Arg.Set no_state, - " Do not use state-error monads, simply use error monads" ); - ( "-template-clauses", - Arg.Set template_decreases_clauses, - " Generate templates for the required decreases clauses, in a\n\ - \ dedicated file. Incompatible with \ - -no-decreases-clauses" ); - ( "-no-split-files", - Arg.Set no_split_files, - " Don't split the definitions between different files for types,\n\ - \ functions, etc." ); - ( "-no-check-inv", - Arg.Set no_check_inv, - " Deactivate the invariant sanity checks performed at every step of\n\ - \ evaluation. Dramatically saves speed." ); - ] - in - (* Sanity check: -template-clauses ==> not -no-decrease-clauses *) - assert ((not !no_decreases_clauses) || not !template_decreases_clauses); - - let spec = Arg.align spec in - let filenames = ref [] in - let add_filename f = filenames := f :: !filenames in - Arg.parse spec add_filename usage; - let fail () = - print_string usage; - exit 1 - in - (* Retrieve and check the filename *) - let filename = - match !filenames with - | [ f ] -> - (* TODO: update the extension *) - if not (Filename.check_suffix f ".llbc") then ( - print_string "Unrecognized file extension"; - fail ()) - else if not (Sys.file_exists f) then ( - print_string "File not found"; - fail ()) - else f - | _ -> - (* For now, we only process one file at a time *) - print_string usage; - exit 1 - in - (* Check the destination directory *) - let dest_dir = - if !dest_dir = "" then Filename.dirname filename else !dest_dir - in - - (* Set up the logging - for now we use default values - TODO: use the - * command-line arguments *) - (* By setting a level for the main_logger_handler, we filter everything *) - Easy_logging.Handlers.set_level main_logger_handler EL.Debug; - main_log#set_level EL.Info; - llbc_of_json_logger#set_level EL.Info; - pre_passes_log#set_level EL.Info; - interpreter_log#set_level EL.Info; - statements_log#set_level EL.Info; - paths_log#set_level EL.Info; - expressions_log#set_level EL.Info; - expansion_log#set_level EL.Info; - borrows_log#set_level EL.Info; - invariants_log#set_level EL.Info; - pure_utils_log#set_level EL.Info; - symbolic_to_pure_log#set_level EL.Info; - pure_micro_passes_log#set_level EL.Info; - pure_to_extract_log#set_level EL.Info; - translate_log#set_level EL.Info; - - (* Load the module *) - let json = Yojson.Basic.from_file filename in - match llbc_crate_of_json json with - | Error s -> - main_log#error "error: %s\n" s; - exit 1 - | Ok m -> - (* Logging *) - main_log#linfo (lazy ("Imported: " ^ filename)); - main_log#ldebug (lazy ("\n" ^ Print.Module.module_to_string m ^ "\n")); - - (* Apply the pre-passes *) - let m = PrePasses.apply_passes m in - - (* Some options for the execution *) - let eval_config = - { - C.check_invariants = not !no_check_inv; - greedy_expand_symbolics_with_borrows = true; - allow_bottom_below_borrow = true; - return_unit_end_abs_with_no_loans = true; - } - in - - (* Test the unit functions with the concrete interpreter *) - if !test_units then I.Test.test_unit_functions eval_config m; - - (* Evaluate the symbolic interpreter on the functions, ignoring the - * functions which contain loops - TODO: remove *) - let synthesize = true in - I.Test.test_functions_symbolic eval_config synthesize m; - - (* Translate the functions *) - let test_unit_functions = !test_trans_units in - let micro_passes_config = - { - Micro.decompose_monadic_let_bindings = !decompose_monads; - unfold_monadic_let_bindings = !unfold_monads; - filter_useless_monadic_calls = !filter_useless_calls; - filter_useless_functions = !filter_useless_functions; - } - in - let trans_config = - { - Translate.eval_config; - mp_config = micro_passes_config; - split_files = not !no_split_files; - test_unit_functions; - extract_decreases_clauses = not !no_decreases_clauses; - extract_template_decreases_clauses = !template_decreases_clauses; - use_state = not !no_state; - } - in - Translate.translate_module filename dest_dir trans_config m; - - (* Print total elapsed time *) - log#linfo - (lazy - (Printf.sprintf "Total execution time: %f seconds" - (Unix.gettimeofday () -. start_time))) diff --git a/src/dune b/src/dune deleted file mode 100644 index e8b53fc5..00000000 --- a/src/dune +++ /dev/null @@ -1,48 +0,0 @@ -;; core: for Core.Unix.mkdir_p - -(executable - (name driver) - (public_name aeneas_driver) - (package aeneas) - (preprocess - (pps ppx_deriving.show ppx_deriving.ord visitors.ppx)) - (libraries ppx_deriving yojson zarith easy_logging core_unix aeneas) - (modules driver)) - -(library - (name aeneas) ;; The name as used in the project - (public_name aeneas) ;; The name as revealed to the projects importing this library - (preprocess - (pps ppx_deriving.show ppx_deriving.ord visitors.ppx)) - (libraries ppx_deriving yojson zarith easy_logging core_unix) - (modules Assumed Collections ConstStrings Contexts Cps Crates Errors - Expressions ExpressionsUtils ExtractToFStar FunsAnalysis Identifiers - InterpreterBorrowsCore InterpreterBorrows InterpreterExpansion - InterpreterExpressions Interpreter InterpreterPaths InterpreterProjectors - InterpreterStatements InterpreterUtils Invariants LlbcAst LlbcAstUtils - LlbcOfJson Logging Meta Names OfJsonBasic PrePasses Print PrintPure - PureMicroPasses Pure PureToExtract PureTypeCheck PureUtils Scalars - StringUtils Substitute SymbolicAst SymbolicToPure SynthesizeSymbolic - TranslateCore Translate TypesAnalysis Types TypesUtils Utils Values - ValuesUtils)) - -(documentation - (package aeneas)) - -(env - (dev - (flags - :standard - -safe-string - -g - ;-dsource - -warn-error - -5-8-9-11-14-33-20-21-26-27-39)) - (release - (flags - :standard - -safe-string - -g - ;-dsource - -warn-error - -5-8-9-11-14-33-20-21-26-27-39))) -- cgit v1.2.3