summaryrefslogtreecommitdiff
path: root/compiler
diff options
context:
space:
mode:
Diffstat (limited to 'compiler')
-rw-r--r--compiler/.ocamlformat1
-rw-r--r--compiler/Assumed.ml300
-rw-r--r--compiler/Collections.ml378
-rw-r--r--compiler/ConstStrings.ml7
-rw-r--r--compiler/Contexts.ml472
-rw-r--r--compiler/Cps.ml193
-rw-r--r--compiler/Crates.ml90
-rw-r--r--compiler/Errors.ml2
-rw-r--r--compiler/Expressions.ml118
-rw-r--r--compiler/ExpressionsUtils.ml10
-rw-r--r--compiler/ExtractToFStar.ml1638
-rw-r--r--compiler/FunsAnalysis.ml143
-rw-r--r--compiler/Identifiers.ml139
-rw-r--r--compiler/Interpreter.ml396
-rw-r--r--compiler/InterpreterBorrows.ml1580
-rw-r--r--compiler/InterpreterBorrowsCore.ml1181
-rw-r--r--compiler/InterpreterExpansion.ml733
-rw-r--r--compiler/InterpreterExpressions.ml720
-rw-r--r--compiler/InterpreterPaths.ml801
-rw-r--r--compiler/InterpreterProjectors.ml543
-rw-r--r--compiler/InterpreterStatements.ml1370
-rw-r--r--compiler/InterpreterUtils.ml245
-rw-r--r--compiler/Invariants.ml794
-rw-r--r--compiler/LlbcAst.ml205
-rw-r--r--compiler/LlbcAstUtils.ml73
-rw-r--r--compiler/LlbcOfJson.ml915
-rw-r--r--compiler/Logging.ml179
-rw-r--r--compiler/Meta.ml44
-rw-r--r--compiler/Names.ml80
-rw-r--r--compiler/OfJsonBasic.ml75
-rw-r--r--compiler/PrePasses.ml54
-rw-r--r--compiler/Print.ml1283
-rw-r--r--compiler/PrintPure.ml594
-rw-r--r--compiler/Pure.ml581
-rw-r--r--compiler/PureMicroPasses.ml1375
-rw-r--r--compiler/PureToExtract.ml723
-rw-r--r--compiler/PureTypeCheck.ml178
-rw-r--r--compiler/PureUtils.ml450
-rw-r--r--compiler/Scalars.ml59
-rw-r--r--compiler/StringUtils.ml106
-rw-r--r--compiler/Substitute.ml357
-rw-r--r--compiler/SymbolicAst.ml98
-rw-r--r--compiler/SymbolicToPure.ml1824
-rw-r--r--compiler/SynthesizeSymbolic.ml156
-rw-r--r--compiler/Translate.ml871
-rw-r--r--compiler/TranslateCore.ml65
-rw-r--r--compiler/Types.ml208
-rw-r--r--compiler/TypesAnalysis.ml328
-rw-r--r--compiler/TypesUtils.ml190
-rw-r--r--compiler/Utils.ml6
-rw-r--r--compiler/Values.ml844
-rw-r--r--compiler/ValuesUtils.ml121
-rw-r--r--compiler/aeneas.opam29
-rw-r--r--compiler/driver.ml208
-rw-r--r--compiler/dune48
-rw-r--r--compiler/dune-project24
-rw-r--r--compiler/fstar/Primitives.fst286
57 files changed, 24491 insertions, 0 deletions
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<T>) -> &'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<T>, 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<T>(&'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 ] (* <T> *) 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>(T) -> Box<T>] *)
+ let box_new_sig : A.fun_sig =
+ {
+ region_params = [];
+ num_early_bound_regions = 0;
+ regions_hierarchy = [];
+ type_params = [ type_param_0 ] (* <T> *);
+ inputs = [ tvar_0 (* T *) ];
+ output = mk_box_ty tvar_0 (* Box<T> *);
+ }
+
+ (** [fn<T>(Box<T>) -> ()] *)
+ let box_free_sig : A.fun_sig =
+ {
+ region_params = [];
+ num_early_bound_regions = 0;
+ regions_hierarchy = [];
+ type_params = [ type_param_0 ] (* <T> *);
+ inputs = [ mk_box_ty tvar_0 (* Box<T> *) ];
+ output = mk_unit_ty (* () *);
+ }
+
+ (** Helper for [Box::deref_shared] and [Box::deref_mut].
+ Returns:
+ [fn<'a, T>(&'a (mut) Box<T>) -> &'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 ] (* <T> *);
+ inputs =
+ [ mk_ref_ty rvar_0 (mk_box_ty tvar_0) is_mut (* &'a (mut) Box<T> *) ];
+ output = mk_ref_ty rvar_0 tvar_0 is_mut (* &'a (mut) T *);
+ }
+
+ (** [fn<'a, T>(&'a Box<T>) -> &'a T] *)
+ let box_deref_shared_sig = box_deref_gen_sig false
+
+ (** [fn<'a, T>(&'a mut Box<T>) -> &'a mut T] *)
+ let box_deref_mut_sig = box_deref_gen_sig true
+
+ (** [fn<T>() -> Vec<T>] *)
+ let vec_new_sig : A.fun_sig =
+ let region_params = [] in
+ let regions_hierarchy = [] in
+ let type_params = [ type_param_0 ] (* <T> *) in
+ let inputs = [] in
+ let output = mk_vec_ty tvar_0 (* Vec<T> *) in
+ {
+ region_params;
+ num_early_bound_regions = 0;
+ regions_hierarchy;
+ type_params;
+ inputs;
+ output;
+ }
+
+ (** [fn<T>(&'a mut Vec<T>, 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 ] (* <T> *) in
+ let inputs =
+ [
+ mk_ref_ty rvar_0 (mk_vec_ty tvar_0) true (* &'a mut Vec<T> *);
+ tvar_0 (* T *);
+ ]
+ in
+ let output = mk_unit_ty (* () *) in
+ {
+ region_params;
+ num_early_bound_regions = 0;
+ regions_hierarchy;
+ type_params;
+ inputs;
+ output;
+ }
+
+ (** [fn<T>(&'a mut Vec<T>, 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 ] (* <T> *) in
+ let inputs =
+ [
+ mk_ref_ty rvar_0 (mk_vec_ty tvar_0) true (* &'a mut Vec<T> *);
+ 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<T>(&'a Vec<T>) -> 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 ] (* <T> *) in
+ let inputs =
+ [ mk_ref_ty rvar_0 (mk_vec_ty tvar_0) false (* &'a Vec<T> *) ]
+ in
+ let output = mk_usize_ty (* usize *) in
+ {
+ region_params;
+ num_early_bound_regions = 0;
+ regions_hierarchy;
+ type_params;
+ inputs;
+ output;
+ }
+
+ (** Helper:
+ [fn<T>(&'a (mut) Vec<T>, 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 ] (* <T> *) in
+ let inputs =
+ [
+ mk_ref_ty rvar_0 (mk_vec_ty tvar_0) is_mut (* &'a (mut) Vec<T> *);
+ 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<T>(&'a Vec<T>, usize) -> &'a T] *)
+ let vec_index_shared_sig : A.fun_sig = vec_index_gen_sig false
+
+ (** [fn<T>(&'a mut Vec<T>, 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<List>),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<ty>
+ - 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::<alloc::boxed::Box<T>>::deref] *)
+ | BoxDerefMut
+ (** [core::ops::deref::DerefMut::<alloc::boxed::Box<T>>::deref_mut] *)
+ | BoxFree
+ | VecNew
+ | VecPush
+ | VecInsert
+ | VecLen
+ | VecIndex (** [core::ops::index::Index::index<alloc::vec::Vec<T>, usize>] *)
+ | VecIndexMut
+ (** [core::ops::index::IndexMut::index_mut<alloc::vec::Vec<T>, 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<T> List<T> {
+ ...
+ }
+ ]}
+
+ 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<Box" ^ t_params ^ ">::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<alloc::vec::Vec" ^ t_params
+ ^ ">::index"
+ | A.VecIndexMut ->
+ "core::ops::index::IndexMut<alloc::vec::Vec" ^ t_params
+ ^ ">::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<alloc::vec::Vec>::index"
+ | A.VecIndexMut ->
+ "core::ops::index::IndexMut<alloc::vec::Vec>::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<T>) {
+ 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<T>] *)
+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<T>] 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
+