diff options
Diffstat (limited to 'src')
54 files changed, 0 insertions, 24152 deletions
diff --git a/src/.ocamlformat b/src/.ocamlformat deleted file mode 100644 index b0ae150e..00000000 --- a/src/.ocamlformat +++ /dev/null @@ -1 +0,0 @@ -doc-comments=before
\ No newline at end of file diff --git a/src/Assumed.ml b/src/Assumed.ml deleted file mode 100644 index cb089c08..00000000 --- a/src/Assumed.ml +++ /dev/null @@ -1,300 +0,0 @@ -(** This module contains various utilities for the assumed functions. - - Note that [Box::free] is peculiar: we don't really handle it as a function, - because it is legal to free a box whose boxed value is [⊥] (it often - happens that we move a value out of a box before freeing this box). - Semantically speaking, we thus handle [Box::free] as a value drop and - not as a function call, and thus never need its signature. - - TODO: implementing the concrete evaluation functions for the assumed - functions is really annoying (see - [InterpreterStatements.eval_non_local_function_call_concrete]). - I think it should be possible, in most situations, to write bodies which - model the behaviour of those unsafe functions. For instance, [Box::deref_mut] - should simply be: - {[ - fn deref_mut<'a, T>(x : &'a mut Box<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/src/Collections.ml b/src/Collections.ml deleted file mode 100644 index 0933b3e4..00000000 --- a/src/Collections.ml +++ /dev/null @@ -1,378 +0,0 @@ -(** The following file redefines several modules like Map or Set. *) - -module F = Format - -module List = struct - include List - - (** Split a list at a given index. - - [split_at ls i] splits [ls] into two lists where the first list has - length [i]. - - Raise [Failure] if the list is too short. - *) - let rec split_at (ls : 'a list) (i : int) = - if i < 0 then raise (Invalid_argument "split_at take positive integers") - else if i = 0 then ([], ls) - else - match ls with - | [] -> - raise - (Failure "The int given to split_at should be <= the list's length") - | x :: ls' -> - let ls1, ls2 = split_at ls' (i - 1) in - (x :: ls1, ls2) - - (** Pop the last element of a list - - Raise [Failure] if the list is empty. - *) - let rec pop_last (ls : 'a list) : 'a list * 'a = - match ls with - | [] -> raise (Failure "The list is empty") - | [ x ] -> ([], x) - | x :: ls -> - let ls, last = pop_last ls in - (x :: ls, last) - - (** Return the n first elements of the list *) - let prefix (n : int) (ls : 'a list) : 'a list = fst (split_at ls n) - - (** Iter and link the iterations. - - Iterate over a list, but call a function between every two elements - (but not before the first element, and not after the last). - *) - let iter_link (link : unit -> unit) (f : 'a -> unit) (ls : 'a list) : unit = - let rec iter ls = - match ls with - | [] -> () - | [ x ] -> f x - | x :: y :: ls -> - f x; - link (); - iter (y :: ls) - in - iter ls - - (** Fold and link the iterations. - - Similar to {!iter_link} but for fold left operations. - *) - let fold_left_link (link : unit -> unit) (f : 'a -> 'b -> 'a) (init : 'a) - (ls : 'b list) : 'a = - let rec fold (acc : 'a) (ls : 'b list) : 'a = - match ls with - | [] -> acc - | [ x ] -> f acc x - | x :: y :: ls -> - let acc = f acc x in - link (); - fold acc (y :: ls) - in - fold init ls - - let to_cons_nil (ls : 'a list) : 'a = - match ls with - | [ x ] -> x - | _ -> raise (Failure "The list should have length exactly one") - - let pop (ls : 'a list) : 'a * 'a list = - match ls with - | x :: ls' -> (x, ls') - | _ -> raise (Failure "The list should have length > 0") -end - -module type OrderedType = sig - include Map.OrderedType - - val to_string : t -> string - val pp_t : Format.formatter -> t -> unit - val show_t : t -> string -end - -(** Ordered string *) -module OrderedString : OrderedType with type t = string = struct - include String - - let to_string s = s - let pp_t fmt s = Format.pp_print_string fmt s - let show_t s = s -end - -module type Map = sig - include Map.S - - val add_list : (key * 'a) list -> 'a t -> 'a t - val of_list : (key * 'a) list -> 'a t - - (** "Simple" pretty printing function. - - Is useful when we need to customize a bit [show_t], but without using - something as burdensome as [pp_t]. - - [to_string (Some indent) m] prints [m] by breaking line after every binding - and inserting [indent]. - *) - val to_string : string option -> ('a -> string) -> 'a t -> string - - val pp : (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a t -> unit - val show : ('a -> string) -> 'a t -> string -end - -module MakeMap (Ord : OrderedType) : Map with type key = Ord.t = struct - module Map = Map.Make (Ord) - include Map - - let add_list bl m = List.fold_left (fun s (key, e) -> add key e s) m bl - let of_list bl = add_list bl empty - - let to_string indent_opt a_to_string m = - let indent, break = - match indent_opt with Some indent -> (indent, "\n") | None -> ("", " ") - in - let sep = "," ^ break in - let ls = - Map.fold - (fun key v ls -> - (indent ^ Ord.to_string key ^ " -> " ^ a_to_string v) :: ls) - m [] - in - match ls with - | [] -> "{}" - | _ -> "{" ^ break ^ String.concat sep (List.rev ls) ^ break ^ "}" - - let pp (pp_a : Format.formatter -> 'a -> unit) (fmt : Format.formatter) - (m : 'a t) : unit = - let pp_string = F.pp_print_string fmt in - let pp_space () = F.pp_print_space fmt () in - pp_string "{"; - F.pp_open_box fmt 2; - Map.iter - (fun key x -> - Ord.pp_t fmt key; - pp_space (); - pp_string "->"; - pp_space (); - pp_a fmt x; - pp_string ","; - F.pp_print_break fmt 1 0) - m; - F.pp_close_box fmt (); - F.pp_print_break fmt 0 0; - pp_string "}" - - let show show_a m = to_string None show_a m -end - -module type Set = sig - include Set.S - - val add_list : elt list -> t -> t - val of_list : elt list -> t - - (** "Simple" pretty printing function. - - Is useful when we need to customize a bit [show_t], but without using - something as burdensome as [pp_t]. - - [to_string (Some indent) s] prints [s] by breaking line after every element - and inserting [indent]. - *) - val to_string : string option -> t -> string - - val pp : Format.formatter -> t -> unit - val show : t -> string - val pairwise_distinct : elt list -> bool -end - -module MakeSet (Ord : OrderedType) : Set with type elt = Ord.t = struct - module Set = Set.Make (Ord) - include Set - - let add_list bl s = List.fold_left (fun s e -> add e s) s bl - let of_list bl = add_list bl empty - - let to_string indent_opt m = - let indent, break = - match indent_opt with Some indent -> (indent, "\n") | None -> ("", " ") - in - let sep = "," ^ break in - let ls = Set.fold (fun v ls -> (indent ^ Ord.to_string v) :: ls) m [] in - match ls with - | [] -> "{}" - | _ -> "{" ^ break ^ String.concat sep (List.rev ls) ^ break ^ "}" - - let pp (fmt : Format.formatter) (m : t) : unit = - let pp_string = F.pp_print_string fmt in - pp_string "{"; - F.pp_open_box fmt 2; - Set.iter - (fun x -> - Ord.pp_t fmt x; - pp_string ","; - F.pp_print_break fmt 1 0) - m; - F.pp_close_box fmt (); - F.pp_print_break fmt 0 0; - pp_string "}" - - let show s = to_string None s - - let pairwise_distinct ls = - let s = ref empty in - let rec check ls = - match ls with - | [] -> true - | x :: ls' -> - if mem x !s then false - else ( - s := add x !s; - check ls') - in - check ls -end - -(** A map where the bindings are injective (i.e., if two keys are distinct, - their bindings are distinct). - - This is useful for instance when generating mappings from our internal - identifiers to names (i.e., strings) when generating code, in order to - make sure that we don't have potentially dangerous collisions. - *) -module type InjMap = sig - type key - type elem - type t - - val empty : t - val is_empty : t -> bool - val mem : key -> t -> bool - val add : key -> elem -> t -> t - val singleton : key -> elem -> t - val remove : key -> t -> t - val compare : (elem -> elem -> int) -> t -> t -> int - val equal : (elem -> elem -> bool) -> t -> t -> bool - val iter : (key -> elem -> unit) -> t -> unit - val fold : (key -> elem -> 'b -> 'b) -> t -> 'b -> 'b - val for_all : (key -> elem -> bool) -> t -> bool - val exists : (key -> elem -> bool) -> t -> bool - val filter : (key -> elem -> bool) -> t -> t - val partition : (key -> elem -> bool) -> t -> t * t - val cardinal : t -> int - val bindings : t -> (key * elem) list - val min_binding : t -> key * elem - val min_binding_opt : t -> (key * elem) option - val max_binding : t -> key * elem - val max_binding_opt : t -> (key * elem) option - val choose : t -> key * elem - val choose_opt : t -> (key * elem) option - val split : key -> t -> t * elem option * t - val find : key -> t -> elem - val find_opt : key -> t -> elem option - val find_first : (key -> bool) -> t -> key * elem - val find_first_opt : (key -> bool) -> t -> (key * elem) option - val find_last : (key -> bool) -> t -> key * elem - val find_last_opt : (key -> bool) -> t -> (key * elem) option - val to_seq : t -> (key * elem) Seq.t - val to_seq_from : key -> t -> (key * elem) Seq.t - val add_seq : (key * elem) Seq.t -> t -> t - val of_seq : (key * elem) Seq.t -> t - val add_list : (key * elem) list -> t -> t - val of_list : (key * elem) list -> t -end - -(** See {!InjMap} *) -module MakeInjMap (Key : OrderedType) (Elem : OrderedType) : - InjMap with type key = Key.t with type elem = Elem.t = struct - module Map = MakeMap (Key) - module Set = MakeSet (Elem) - - type key = Key.t - type elem = Elem.t - type t = { map : elem Map.t; elems : Set.t } - - let empty = { map = Map.empty; elems = Set.empty } - let is_empty m = Map.is_empty m.map - let mem k m = Map.mem k m.map - - let add k e m = - assert (not (Set.mem e m.elems)); - { map = Map.add k e m.map; elems = Set.add e m.elems } - - let singleton k e = { map = Map.singleton k e; elems = Set.singleton e } - - let remove k m = - match Map.find_opt k m.map with - | None -> m - | Some x -> { map = Map.remove k m.map; elems = Set.remove x m.elems } - - let compare f m1 m2 = Map.compare f m1.map m2.map - let equal f m1 m2 = Map.equal f m1.map m2.map - let iter f m = Map.iter f m.map - let fold f m x = Map.fold f m.map x - let for_all f m = Map.for_all f m.map - let exists f m = Map.exists f m.map - - (** Small helper *) - let bindings_to_elems_set (bls : (key * elem) list) : Set.t = - let elems = List.map snd bls in - let elems = List.fold_left (fun s e -> Set.add e s) Set.empty elems in - elems - - (** Small helper *) - let map_to_elems_set (map : elem Map.t) : Set.t = - bindings_to_elems_set (Map.bindings map) - - (** Small helper *) - let map_to_t (map : elem Map.t) : t = - let elems = map_to_elems_set map in - { map; elems } - - let filter f m = - let map = Map.filter f m.map in - let elems = map_to_elems_set map in - { map; elems } - - let partition f m = - let map1, map2 = Map.partition f m.map in - (map_to_t map1, map_to_t map2) - - let cardinal m = Map.cardinal m.map - let bindings m = Map.bindings m.map - let min_binding m = Map.min_binding m.map - let min_binding_opt m = Map.min_binding_opt m.map - let max_binding m = Map.max_binding m.map - let max_binding_opt m = Map.max_binding_opt m.map - let choose m = Map.choose m.map - let choose_opt m = Map.choose_opt m.map - - let split k m = - let l, data, r = Map.split k m.map in - let l = map_to_t l in - let r = map_to_t r in - (l, data, r) - - let find k m = Map.find k m.map - let find_opt k m = Map.find_opt k m.map - let find_first k m = Map.find_first k m.map - let find_first_opt k m = Map.find_first_opt k m.map - let find_last k m = Map.find_last k m.map - let find_last_opt k m = Map.find_last_opt k m.map - let to_seq m = Map.to_seq m.map - let to_seq_from k m = Map.to_seq_from k m.map - - let rec add_seq s m = - (* Note that it is important to check that we don't add bindings mapping - * to the same element *) - match s () with - | Seq.Nil -> m - | Seq.Cons ((k, e), s) -> - let m = add k e m in - add_seq s m - - let of_seq s = add_seq s empty - let add_list ls m = List.fold_left (fun m (key, elem) -> add key elem m) m ls - let of_list ls = add_list ls empty -end diff --git a/src/ConstStrings.ml b/src/ConstStrings.ml deleted file mode 100644 index ae169a2e..00000000 --- a/src/ConstStrings.ml +++ /dev/null @@ -1,7 +0,0 @@ -(** Some utilities *) - -(** Basename for state variables (introduced when using state-error monads) *) -let state_basename = "st" - -(** ADT constructor prefix (used when pretty-printing) *) -let constructor_prefix = "Mk" diff --git a/src/Contexts.ml b/src/Contexts.ml deleted file mode 100644 index 510976f4..00000000 --- a/src/Contexts.ml +++ /dev/null @@ -1,472 +0,0 @@ -open Types -open Values -open LlbcAst -module V = Values -open ValuesUtils - -(** Some global counters. - - Note that those counters were initially stored in {!eval_ctx} values, - but it proved better to make them global and stateful: - - when branching (and thus executing on several paths with different - contexts) it is better to really have unique ids everywhere (and - not have fresh ids shared by several contexts even though introduced - after the branching) because at some point we might need to merge the - different contexts - - also, it is a lot more convenient to not store those counters in contexts - objects - - ============= - **WARNING**: - ============= - Pay attention when playing with closures, as you may not always generate - fresh identifiers without noticing it, especially when using type abbreviations. - For instance, consider the following: - {[ - type fun_type = unit -> ... - fn f x : fun_type = - let id = fresh_id () in - ... - - let g = f x in // <-- the fresh identifier gets generated here - let x1 = g () in // <-- no fresh generation here - let x2 = g () in - ... - ]} - - This is why, in such cases, we often introduce all the inputs, even - when they are not used (which happens!). - {[ - fn f x : fun_type = - fun .. -> - let id = fresh_id () in - ... - ]} - - Note that in practice, we never reuse closures, except when evaluating - a branching in the execution (which is fine, because the branches evaluate - independentely of each other). Still, it is always a good idea to be - defensive. - - However, the same problem arises with logging. - - Also, a more defensive way would be to not use global references, and - store the counters in the evaluation context. This is actually what was - originally done, before we updated the code to use global counters because - it proved more convenient (and even before updating the code of the - interpreter to use CPS). - *) - -let symbolic_value_id_counter, fresh_symbolic_value_id = - SymbolicValueId.fresh_stateful_generator () - -let borrow_id_counter, fresh_borrow_id = BorrowId.fresh_stateful_generator () -let region_id_counter, fresh_region_id = RegionId.fresh_stateful_generator () - -let abstraction_id_counter, fresh_abstraction_id = - AbstractionId.fresh_stateful_generator () - -let fun_call_id_counter, fresh_fun_call_id = - FunCallId.fresh_stateful_generator () - -(** We shouldn't need to reset the global counters, but it might be good to - do it from time to time, for instance every time we start evaluating/ - synthesizing a function. - - The reasons are manifold: - - it might prevent the counters from overflowing (although this seems - extremely unlikely - as a side node: we have overflow checks to make - sure the synthesis doesn't get impacted by potential overflows) - - most importantly, it allows to always manipulate low values, which - is always a lot more readable when debugging - *) -let reset_global_counters () = - symbolic_value_id_counter := SymbolicValueId.generator_zero; - borrow_id_counter := BorrowId.generator_zero; - region_id_counter := RegionId.generator_zero; - abstraction_id_counter := AbstractionId.generator_zero; - fun_call_id_counter := FunCallId.generator_zero - -(** A binder used in an environment, to map a variable to a value *) -type binder = { - index : VarId.id; (** Unique variable identifier *) - name : string option; (** Possible name *) -} -[@@deriving show] - -(** Environment value: mapping from variable to value, abstraction (only - used in symbolic mode) or stack frame delimiter. - - TODO: rename Var (-> Binding?) - *) -type env_elem = - | Var of (binder option[@opaque]) * typed_value - (** Variable binding - the binder is None if the variable is a dummy variable - (we use dummy variables to store temporaries while doing bookkeeping such - as ending borrows for instance). *) - | Abs of abs - | Frame -[@@deriving - show, - visitors - { - name = "iter_env_elem"; - variety = "iter"; - ancestors = [ "iter_abs" ]; - nude = true (* Don't inherit {!VisitorsRuntime.iter} *); - concrete = true; - }, - visitors - { - name = "map_env_elem"; - variety = "map"; - ancestors = [ "map_abs" ]; - nude = true (* Don't inherit {!VisitorsRuntime.iter} *); - concrete = true; - }] - -type env = env_elem list -[@@deriving - show, - visitors - { - name = "iter_env"; - variety = "iter"; - ancestors = [ "iter_env_elem" ]; - nude = true (* Don't inherit {!VisitorsRuntime.iter} *); - concrete = true; - }, - visitors - { - name = "map_env"; - variety = "map"; - ancestors = [ "map_env_elem" ]; - nude = true (* Don't inherit {!VisitorsRuntime.iter} *); - concrete = true; - }] - -type interpreter_mode = ConcreteMode | SymbolicMode [@@deriving show] - -type config = { - mode : interpreter_mode; - (** Concrete mode (interpreter) or symbolic mode (for synthesis) **) - check_invariants : bool; - (** Check that invariants are maintained whenever we execute a statement *) - greedy_expand_symbolics_with_borrows : bool; - (** Expand all symbolic values containing borrows upon introduction - allows - to use restrict ourselves to a simpler model for the projectors over - symbolic values. - The interpreter fails if doing this requires to do a branching (because - we need to expand an enumeration with strictly more than one variant) - or if we need to expand a recursive type (because this leads to looping). - *) - allow_bottom_below_borrow : bool; - (** Experimental. - - We sometimes want to temporarily break the invariant that there is no - bottom value below a borrow. If this value is true, we don't check - the invariant, and the rule becomes: we can't end a borrow *if* it contains - a bottom value. The consequence is that it becomes ok to temporarily - have bottom below a borrow, if we put something else inside before ending - the borrow. - - For instance, when evaluating an assignment, we move the value which - will be overwritten then do some administrative tasks with the borrows, - then move the rvalue to its destination. We currently want to be able - to check the invariants every time we end a borrow/an abstraction, - meaning at intermediate steps of the assignment where the invariants - might actually be broken. - *) - return_unit_end_abs_with_no_loans : bool; - (** If a function doesn't return any borrows, we can immediately call - its backward functions. If this option is on, whenever we call a - function *and* this function returns unit, we immediately end all the - abstractions which are introduced and don't contain loans. This can be - useful to make the code cleaner (the backward function is introduced - where the function call happened) and make sure all forward functions - with no return value are followed by a backward function. - *) -} -[@@deriving show] - -(** See {!config} *) -type partial_config = { - check_invariants : bool; - greedy_expand_symbolics_with_borrows : bool; - allow_bottom_below_borrow : bool; - return_unit_end_abs_with_no_loans : bool; -} - -let config_of_partial (mode : interpreter_mode) (config : partial_config) : - config = - { - mode; - check_invariants = config.check_invariants; - greedy_expand_symbolics_with_borrows = - config.greedy_expand_symbolics_with_borrows; - allow_bottom_below_borrow = config.allow_bottom_below_borrow; - return_unit_end_abs_with_no_loans = config.return_unit_end_abs_with_no_loans; - } - -type type_context = { - type_decls_groups : Crates.type_declaration_group TypeDeclId.Map.t; - type_decls : type_decl TypeDeclId.Map.t; - type_infos : TypesAnalysis.type_infos; -} -[@@deriving show] - -type fun_context = { fun_decls : fun_decl FunDeclId.Map.t } [@@deriving show] - -type global_context = { global_decls : global_decl GlobalDeclId.Map.t } -[@@deriving show] - -(** Evaluation context *) -type eval_ctx = { - type_context : type_context; - fun_context : fun_context; - global_context : global_context; - type_vars : type_var list; - env : env; - ended_regions : RegionId.Set.t; -} -[@@deriving show] - -let lookup_type_var (ctx : eval_ctx) (vid : TypeVarId.id) : type_var = - TypeVarId.nth ctx.type_vars vid - -let opt_binder_has_vid (bv : binder option) (vid : VarId.id) : bool = - match bv with Some bv -> bv.index = vid | None -> false - -let ctx_lookup_binder (ctx : eval_ctx) (vid : VarId.id) : binder = - (* TOOD: we might want to stop at the end of the frame *) - let rec lookup env = - match env with - | [] -> - raise (Invalid_argument ("Variable not found: " ^ VarId.to_string vid)) - | Var (var, _) :: env' -> - if opt_binder_has_vid var vid then Option.get var else lookup env' - | (Abs _ | Frame) :: env' -> lookup env' - in - lookup ctx.env - -(** TODO: make this more efficient with maps *) -let ctx_lookup_type_decl (ctx : eval_ctx) (tid : TypeDeclId.id) : type_decl = - TypeDeclId.Map.find tid ctx.type_context.type_decls - -(** TODO: make this more efficient with maps *) -let ctx_lookup_fun_decl (ctx : eval_ctx) (fid : FunDeclId.id) : fun_decl = - FunDeclId.Map.find fid ctx.fun_context.fun_decls - -(** TODO: make this more efficient with maps *) -let ctx_lookup_global_decl (ctx : eval_ctx) (gid : GlobalDeclId.id) : - global_decl = - GlobalDeclId.Map.find gid ctx.global_context.global_decls - -(** Retrieve a variable's value in an environment *) -let env_lookup_var_value (env : env) (vid : VarId.id) : typed_value = - (* We take care to stop at the end of current frame: different variables - in different frames can have the same id! - *) - let rec lookup env = - match env with - | [] -> failwith "Unexpected" - | Var (var, v) :: env' -> - if opt_binder_has_vid var vid then v else lookup env' - | Abs _ :: env' -> lookup env' - | Frame :: _ -> failwith "End of frame" - in - lookup env - -(** Retrieve a variable's value in an evaluation context *) -let ctx_lookup_var_value (ctx : eval_ctx) (vid : VarId.id) : typed_value = - env_lookup_var_value ctx.env vid - -(** Update a variable's value in an environment - - This is a helper function: it can break invariants and doesn't perform - any check. -*) -let env_update_var_value (env : env) (vid : VarId.id) (nv : typed_value) : env = - (* We take care to stop at the end of current frame: different variables - in different frames can have the same id! - *) - let rec update env = - match env with - | [] -> failwith "Unexpected" - | Var (var, v) :: env' -> - if opt_binder_has_vid var vid then Var (var, nv) :: env' - else Var (var, v) :: update env' - | Abs abs :: env' -> Abs abs :: update env' - | Frame :: _ -> failwith "End of frame" - in - update env - -let var_to_binder (var : var) : binder = { index = var.index; name = var.name } - -(** Update a variable's value in an evaluation context. - - This is a helper function: it can break invariants and doesn't perform - any check. -*) -let ctx_update_var_value (ctx : eval_ctx) (vid : VarId.id) (nv : typed_value) : - eval_ctx = - { ctx with env = env_update_var_value ctx.env vid nv } - -(** Push a variable in the context's environment. - - Checks that the pushed variable and its value have the same type (this - is important). -*) -let ctx_push_var (ctx : eval_ctx) (var : var) (v : typed_value) : eval_ctx = - assert (var.var_ty = v.ty); - let bv = var_to_binder var in - { ctx with env = Var (Some bv, v) :: ctx.env } - -(** Push a list of variables. - - Checks that the pushed variables and their values have the same type (this - is important). -*) -let ctx_push_vars (ctx : eval_ctx) (vars : (var * typed_value) list) : eval_ctx - = - assert ( - List.for_all - (fun (var, (value : typed_value)) -> var.var_ty = value.ty) - vars); - let vars = - List.map (fun (var, value) -> Var (Some (var_to_binder var), value)) vars - in - let vars = List.rev vars in - { ctx with env = List.append vars ctx.env } - -(** Push a dummy variable in the context's environment. *) -let ctx_push_dummy_var (ctx : eval_ctx) (v : typed_value) : eval_ctx = - { ctx with env = Var (None, v) :: ctx.env } - -(** Pop the first dummy variable from a context's environment. *) -let ctx_pop_dummy_var (ctx : eval_ctx) : eval_ctx * typed_value = - let rec pop_var (env : env) : env * typed_value = - match env with - | [] -> failwith "Could not find a dummy variable" - | Var (None, v) :: env -> (env, v) - | ee :: env -> - let env, v = pop_var env in - (ee :: env, v) - in - let env, v = pop_var ctx.env in - ({ ctx with env }, v) - -(** Read the first dummy variable in a context's environment. *) -let ctx_read_first_dummy_var (ctx : eval_ctx) : typed_value = - let rec read_var (env : env) : typed_value = - match env with - | [] -> failwith "Could not find a dummy variable" - | Var (None, v) :: _env -> v - | _ :: env -> read_var env - in - read_var ctx.env - -(** Push an uninitialized variable (which thus maps to {!Values.Bottom}) *) -let ctx_push_uninitialized_var (ctx : eval_ctx) (var : var) : eval_ctx = - ctx_push_var ctx var (mk_bottom var.var_ty) - -(** Push a list of uninitialized variables (which thus map to {!Values.Bottom}) *) -let ctx_push_uninitialized_vars (ctx : eval_ctx) (vars : var list) : eval_ctx = - let vars = List.map (fun v -> (v, mk_bottom v.var_ty)) vars in - ctx_push_vars ctx vars - -let env_lookup_abs (env : env) (abs_id : V.AbstractionId.id) : V.abs = - let rec lookup env = - match env with - | [] -> failwith "Unexpected" - | Var (_, _) :: env' -> lookup env' - | Abs abs :: env' -> if abs.abs_id = abs_id then abs else lookup env' - | Frame :: env' -> lookup env' - in - lookup env - -let ctx_lookup_abs (ctx : eval_ctx) (abs_id : V.AbstractionId.id) : V.abs = - env_lookup_abs ctx.env abs_id - -let ctx_type_decl_is_rec (ctx : eval_ctx) (id : TypeDeclId.id) : bool = - let decl_group = TypeDeclId.Map.find id ctx.type_context.type_decls_groups in - match decl_group with Crates.Rec _ -> true | Crates.NonRec _ -> false - -(** Visitor to iterate over the values in the *current* frame *) -class ['self] iter_frame = - object (self : 'self) - inherit [_] V.iter_abs - - method visit_Var : 'acc -> binder option -> typed_value -> unit = - fun acc _vid v -> self#visit_typed_value acc v - - method visit_Abs : 'acc -> abs -> unit = - fun acc abs -> self#visit_abs acc abs - - method visit_env_elem : 'acc -> env_elem -> unit = - fun acc em -> - match em with - | Var (vid, v) -> self#visit_Var acc vid v - | Abs abs -> self#visit_Abs acc abs - | Frame -> failwith "Unreachable" - - method visit_env : 'acc -> env -> unit = - fun acc env -> - match env with - | [] -> () - | Frame :: _ -> (* We stop here *) () - | em :: env -> - self#visit_env_elem acc em; - self#visit_env acc env - end - -(** Visitor to map over the values in the *current* frame *) -class ['self] map_frame_concrete = - object (self : 'self) - inherit [_] V.map_abs - - method visit_Var : 'acc -> binder option -> typed_value -> env_elem = - fun acc vid v -> - let v = self#visit_typed_value acc v in - Var (vid, v) - - method visit_Abs : 'acc -> abs -> env_elem = - fun acc abs -> Abs (self#visit_abs acc abs) - - method visit_env_elem : 'acc -> env_elem -> env_elem = - fun acc em -> - match em with - | Var (vid, v) -> self#visit_Var acc vid v - | Abs abs -> self#visit_Abs acc abs - | Frame -> failwith "Unreachable" - - method visit_env : 'acc -> env -> env = - fun acc env -> - match env with - | [] -> [] - | Frame :: env -> (* We stop here *) Frame :: env - | em :: env -> - let em = self#visit_env_elem acc em in - let env = self#visit_env acc env in - em :: env - end - -(** Visitor to iterate over the values in a context *) -class ['self] iter_eval_ctx = - object (_self : 'self) - inherit [_] iter_env as super - - method visit_eval_ctx : 'acc -> eval_ctx -> unit = - fun acc ctx -> super#visit_env acc ctx.env - end - -(** Visitor to map the values in a context *) -class ['self] map_eval_ctx = - object (_self : 'self) - inherit [_] map_env as super - - method visit_eval_ctx : 'acc -> eval_ctx -> eval_ctx = - fun acc ctx -> - let env = super#visit_env acc ctx.env in - { ctx with env } - end diff --git a/src/Cps.ml b/src/Cps.ml deleted file mode 100644 index c2c0363b..00000000 --- a/src/Cps.ml +++ /dev/null @@ -1,193 +0,0 @@ -(** This module defines various utilities to write the interpretation functions - in continuation passing style. *) - -module T = Types -module V = Values -module C = Contexts -module SA = SymbolicAst - -(** TODO: change the name *) -type eval_error = EPanic - -(** Result of evaluating a statement *) -type statement_eval_res = - | Unit - | Break of int - | Continue of int - | Return - | Panic - -(** Synthesized expresssion - dummy for now *) -type sexpr = SOne | SList of sexpr list - -type eval_result = SA.expression option - -(** Continuation function *) -type m_fun = C.eval_ctx -> eval_result - -(** Continuation taking another continuation as parameter *) -type cm_fun = m_fun -> m_fun - -(** Continuation taking a typed value as parameter - TODO: use more *) -type typed_value_m_fun = V.typed_value -> m_fun - -(** Continuation taking another continuation as parameter and a typed - value as parameter. - *) -type typed_value_cm_fun = V.typed_value -> cm_fun - -(** Type of a continuation used when evaluating a statement *) -type st_m_fun = statement_eval_res -> m_fun - -(** Type of a continuation used when evaluating a statement *) -type st_cm_fun = st_m_fun -> m_fun - -(** Convert a unit function to a cm function *) -let unit_to_cm_fun (f : C.eval_ctx -> unit) : cm_fun = - fun cf ctx -> - f ctx; - cf ctx - -(** *) -let update_to_cm_fun (f : C.eval_ctx -> C.eval_ctx) : cm_fun = - fun cf ctx -> - let ctx = f ctx in - cf ctx - -(** Composition of functions taking continuations as parameters. - We tried to make this as general as possible. *) -let comp (f : 'c -> 'd -> 'e) (g : ('a -> 'b) -> 'c) : ('a -> 'b) -> 'd -> 'e = - fun cf ctx -> f (g cf) ctx - -let comp_unit (f : cm_fun) (g : C.eval_ctx -> unit) : cm_fun = - comp f (unit_to_cm_fun g) - -let comp_update (f : cm_fun) (g : C.eval_ctx -> C.eval_ctx) : cm_fun = - comp f (update_to_cm_fun g) - -(** This is just a test, to check that {!comp} is general enough to handle a case - where a function must compute a value and give it to the continuation. - It happens for functions like {!InterpreterExpressions.eval_operand}. - - Keeping this here also makes it a good reference, when one wants to figure - out the signatures he should use for such a composition. - *) -let comp_ret_val (f : (V.typed_value -> m_fun) -> m_fun) - (g : m_fun -> V.typed_value -> m_fun) : cm_fun = - comp f g - -let apply (f : cm_fun) (g : m_fun) : m_fun = fun ctx -> f g ctx -let id_cm_fun : cm_fun = fun cf ctx -> cf ctx - -(** If we have a list of [inputs] of type ['a list] and a function [f] which - evaluates one element of type ['a] to compute a result of type ['b] before - giving it to a continuation, the following function performs a fold operation: - it evaluates all the inputs one by one by accumulating the results in a list, - and gives the list to a continuation. - - Note that we make sure that the results are listed in the order in - which they were computed (the first element of the list is the result - of applying [f] to the first element of the inputs). - - See the unit test below for an illustration. - *) -let fold_left_apply_continuation (f : 'a -> ('c -> 'd) -> 'c -> 'd) - (inputs : 'a list) (cf : 'c -> 'd) : 'c -> 'd = - let rec eval_list (inputs : 'a list) (cf : 'c -> 'd) : 'c -> 'd = - fun ctx -> - match inputs with - | [] -> cf ctx - | x :: inputs -> comp (f x) (fun cf -> eval_list inputs cf) cf ctx - in - eval_list inputs cf - -(** Unit test/example for {!fold_left_apply_continuation} *) -let _ = - fold_left_apply_continuation - (fun x cf (ctx : int) -> cf (ctx + x)) - [ 1; 20; 300; 4000 ] - (fun (ctx : int) -> assert (ctx = 4321)) - 0 - -(** If we have a list of [inputs] of type ['a list] and a function [f] which - evaluates one element of type ['a] to compute a result of type ['b] before - giving it to a continuation, the following function performs a fold operation: - it evaluates all the inputs one by one by accumulating the results in a list, - and gives the list to a continuation. - - Note that we make sure that the results are listed in the order in - which they were computed (the first element of the list is the result - of applying [f] to the first element of the inputs). - - See the unit test below for an illustration. - *) -let fold_left_list_apply_continuation (f : 'a -> ('b -> 'c -> 'd) -> 'c -> 'd) - (inputs : 'a list) (cf : 'b list -> 'c -> 'd) : 'c -> 'd = - let rec eval_list (inputs : 'a list) (cf : 'b list -> 'c -> 'd) - (outputs : 'b list) : 'c -> 'd = - fun ctx -> - match inputs with - | [] -> cf (List.rev outputs) ctx - | x :: inputs -> - comp (f x) (fun cf v -> eval_list inputs cf (v :: outputs)) cf ctx - in - eval_list inputs cf [] - -(** Unit test/example for {!fold_left_list_apply_continuation} *) -let _ = - fold_left_list_apply_continuation - (fun x cf (ctx : unit) -> cf (10 + x) ctx) - [ 0; 1; 2; 3; 4 ] - (fun values _ctx -> assert (values = [ 10; 11; 12; 13; 14 ])) - () - -(** Composition of functions taking continuations as parameters. - - We sometimes have the following situation, where we want to compose three - functions [send], [transmit] and [receive] such that: - - those three functions take continuations as parameters - - [send] generates a value and gives it to its continuation - - [receive] expects a value (so we can compose [send] and [receive] like - so: [comp send receive]) - - [transmit] doesn't expect any value and needs to be called between [send] - and [receive] - - In this situation, we need to take the value given by [send] and "transmit" - it to [receive]. - - This is what this function does (see the unit test below for an illustration). - *) -let comp_transmit (f : ('v -> 'm) -> 'n) (g : 'm -> 'm) : ('v -> 'm) -> 'n = - fun cf -> f (fun v -> g (cf v)) - -(** Example of use of {!comp_transmit} *) -let () = - let return3 (cf : int -> unit -> unit) (ctx : unit) = cf 3 ctx in - let do_nothing (cf : unit -> unit) (ctx : unit) = cf ctx in - let consume3 (x : int) (ctx : unit) : unit = - assert (x = 3); - ctx - in - let cc = comp_transmit return3 do_nothing in - let cc = cc consume3 in - cc () - -(** Sometimes, we want to compose a function with a continuation which checks - its computed value and its updated context, before transmitting them - *) -let comp_check_value (f : ('v -> 'ctx -> 'a) -> 'ctx -> 'b) - (g : 'v -> 'ctx -> unit) : ('v -> 'ctx -> 'a) -> 'ctx -> 'b = - fun cf -> - f (fun v ctx -> - g v ctx; - cf v ctx) - -(** This case is similar to {!comp_check_value}, but even simpler (we only check - the context) - *) -let comp_check_ctx (f : ('ctx -> 'a) -> 'ctx -> 'b) (g : 'ctx -> unit) : - ('ctx -> 'a) -> 'ctx -> 'b = - fun cf -> - f (fun ctx -> - g ctx; - cf ctx) diff --git a/src/Crates.ml b/src/Crates.ml deleted file mode 100644 index 844afb94..00000000 --- a/src/Crates.ml +++ /dev/null @@ -1,90 +0,0 @@ -open Types -open LlbcAst - -type 'id g_declaration_group = NonRec of 'id | Rec of 'id list -[@@deriving show] - -type type_declaration_group = TypeDeclId.id g_declaration_group -[@@deriving show] - -type fun_declaration_group = FunDeclId.id g_declaration_group [@@deriving show] - -(** Module declaration. Globals cannot be mutually recursive. *) -type declaration_group = - | Type of type_declaration_group - | Fun of fun_declaration_group - | Global of GlobalDeclId.id -[@@deriving show] - -type llbc_crate = { - name : string; - declarations : declaration_group list; - types : type_decl list; - functions : fun_decl list; - globals : global_decl list; -} -(** LLBC crate *) - -let compute_defs_maps (c : llbc_crate) : - type_decl TypeDeclId.Map.t - * fun_decl FunDeclId.Map.t - * global_decl GlobalDeclId.Map.t = - let types_map = - List.fold_left - (fun m (def : type_decl) -> TypeDeclId.Map.add def.def_id def m) - TypeDeclId.Map.empty c.types - in - let funs_map = - List.fold_left - (fun m (def : fun_decl) -> FunDeclId.Map.add def.def_id def m) - FunDeclId.Map.empty c.functions - in - let globals_map = - List.fold_left - (fun m (def : global_decl) -> GlobalDeclId.Map.add def.def_id def m) - GlobalDeclId.Map.empty c.globals - in - (types_map, funs_map, globals_map) - -(** Split a module's declarations between types, functions and globals *) -let split_declarations (decls : declaration_group list) : - type_declaration_group list - * fun_declaration_group list - * GlobalDeclId.id list = - let rec split decls = - match decls with - | [] -> ([], [], []) - | d :: decls' -> ( - let types, funs, globals = split decls' in - match d with - | Type decl -> (decl :: types, funs, globals) - | Fun decl -> (types, decl :: funs, globals) - | Global decl -> (types, funs, decl :: globals)) - in - split decls - -(** Split a module's declarations into three maps from type/fun/global ids to - declaration groups. - *) -let split_declarations_to_group_maps (decls : declaration_group list) : - type_declaration_group TypeDeclId.Map.t - * fun_declaration_group FunDeclId.Map.t - * GlobalDeclId.Set.t = - let module G (M : Map.S) = struct - let add_group (map : M.key g_declaration_group M.t) - (group : M.key g_declaration_group) : M.key g_declaration_group M.t = - match group with - | NonRec id -> M.add id group map - | Rec ids -> List.fold_left (fun map id -> M.add id group map) map ids - - let create_map (groups : M.key g_declaration_group list) : - M.key g_declaration_group M.t = - List.fold_left add_group M.empty groups - end in - let types, funs, globals = split_declarations decls in - let module TG = G (TypeDeclId.Map) in - let types = TG.create_map types in - let module FG = G (FunDeclId.Map) in - let funs = FG.create_map funs in - let globals = GlobalDeclId.Set.of_list globals in - (types, funs, globals) diff --git a/src/Errors.ml b/src/Errors.ml deleted file mode 100644 index 31a53cf4..00000000 --- a/src/Errors.ml +++ /dev/null @@ -1,2 +0,0 @@ -exception IntegerOverflow of unit -exception Unimplemented diff --git a/src/Expressions.ml b/src/Expressions.ml deleted file mode 100644 index e2eaf1e7..00000000 --- a/src/Expressions.ml +++ /dev/null @@ -1,118 +0,0 @@ -open Types -open Values - -type field_proj_kind = - | ProjAdt of TypeDeclId.id * VariantId.id option - | ProjOption of VariantId.id - (** Option is an assumed type, coming from the standard library *) - | ProjTuple of int -[@@deriving show] -(* arity of the tuple *) - -type projection_elem = - | Deref - | DerefBox - | Field of field_proj_kind * FieldId.id -[@@deriving show] - -type projection = projection_elem list [@@deriving show] -type place = { var_id : VarId.id; projection : projection } [@@deriving show] -type borrow_kind = Shared | Mut | TwoPhaseMut [@@deriving show] - -type unop = - | Not - | Neg - | Cast of integer_type * integer_type - (** Cast an integer from a source type to a target type *) -[@@deriving show, ord] - -(** A binary operation - - Note that we merge checked binops and unchecked binops: we perform a - micro-pass on the MIR AST to remove the assertions introduced by rustc, - and later extract the binops which can fail (addition, substraction, etc.) - or have preconditions (division, remainder...) to monadic functions. - *) -type binop = - | BitXor - | BitAnd - | BitOr - | Eq - | Lt - | Le - | Ne - | Ge - | Gt - | Div - | Rem - | Add - | Sub - | Mul - | Shl - | Shr -[@@deriving show, ord] - -let all_binops = - [ - BitXor; - BitAnd; - BitOr; - Eq; - Lt; - Le; - Ne; - Ge; - Gt; - Div; - Rem; - Add; - Sub; - Mul; - Shl; - Shr; - ] - -type operand = - | Copy of place - | Move of place - | Constant of ety * constant_value -[@@deriving show] - -(** An aggregated ADT. - - Note that ADTs are desaggregated at some point in MIR. For instance, if - we have in Rust: - {[ - let ls = Cons(hd, tl); - ]} - - In MIR we have (yes, the discriminant update happens *at the end* for some - reason): - {[ - (ls as Cons).0 = move hd; - (ls as Cons).1 = move tl; - discriminant(ls) = 0; // assuming [Cons] is the variant of index 0 - ]} - - Note that in our semantics, we handle both cases (in case of desaggregated - initialization, [ls] is initialized to [⊥], then this [⊥] is expanded to - [Cons (⊥, ⊥)] upon the first assignment, at which point we can initialize - the field 0, etc.). - *) -type aggregate_kind = - | AggregatedTuple - | AggregatedOption of VariantId.id * ety - (* TODO: AggregatedOption should be merged with AggregatedAdt *) - | AggregatedAdt of - TypeDeclId.id * VariantId.id option * erased_region list * ety list -[@@deriving show] - -(* TODO: move the aggregate kind to operands *) -type rvalue = - | Use of operand - | Ref of place * borrow_kind - | UnaryOp of unop * operand - | BinaryOp of binop * operand * operand - | Discriminant of place - | Aggregate of aggregate_kind * operand list -[@@deriving show] diff --git a/src/ExpressionsUtils.ml b/src/ExpressionsUtils.ml deleted file mode 100644 index c3ccfb15..00000000 --- a/src/ExpressionsUtils.ml +++ /dev/null @@ -1,10 +0,0 @@ -module E = Expressions - -let unop_can_fail (unop : E.unop) : bool = - match unop with Neg | Cast _ -> true | Not -> false - -let binop_can_fail (binop : E.binop) : bool = - match binop with - | BitXor | BitAnd | BitOr | Eq | Lt | Le | Ne | Ge | Gt -> false - | Div | Rem | Add | Sub | Mul -> true - | Shl | Shr -> raise Errors.Unimplemented diff --git a/src/ExtractToFStar.ml b/src/ExtractToFStar.ml deleted file mode 100644 index 5d212941..00000000 --- a/src/ExtractToFStar.ml +++ /dev/null @@ -1,1638 +0,0 @@ -(** Extract to F* *) - -open Errors -open Pure -open PureUtils -open TranslateCore -open PureToExtract -open StringUtils -module F = Format - -(** A qualifier for a type definition. - - Controls whether we should use [type ...] or [and ...] (for mutually - recursive datatypes). - *) -type type_decl_qualif = - | Type (** [type t = ...] *) - | And (** [type t0 = ... and t1 = ...] *) - | AssumeType (** [assume type t] *) - | TypeVal (** In an fsti: [val t : Type0] *) - -(** A qualifier for function definitions. - - Controls whether we should use [let ...], [let rec ...] or [and ...], - or only generate a declaration with [val] or [assume val] - *) -type fun_decl_qualif = Let | LetRec | And | Val | AssumeVal - -let fun_decl_qualif_keyword (qualif : fun_decl_qualif) : string = - match qualif with - | Let -> "let" - | LetRec -> "let rec" - | And -> "and" - | Val -> "val" - | AssumeVal -> "assume val" - -(** Small helper to compute the name of an int type *) -let fstar_int_name (int_ty : integer_type) = - match int_ty with - | Isize -> "isize" - | I8 -> "i8" - | I16 -> "i16" - | I32 -> "i32" - | I64 -> "i64" - | I128 -> "i128" - | Usize -> "usize" - | U8 -> "u8" - | U16 -> "u16" - | U32 -> "u32" - | U64 -> "u64" - | U128 -> "u128" - -(** Small helper to compute the name of a unary operation *) -let fstar_unop_name (unop : unop) : string = - match unop with - | Not -> "not" - | Neg int_ty -> fstar_int_name int_ty ^ "_neg" - | Cast _ -> raise (Failure "Unsupported") - -(** Small helper to compute the name of a binary operation (note that many - binary operations like "less than" are extracted to primitive operations, - like [<]. - *) -let fstar_named_binop_name (binop : E.binop) (int_ty : integer_type) : string = - let binop = - match binop with - | Div -> "div" - | Rem -> "rem" - | Add -> "add" - | Sub -> "sub" - | Mul -> "mul" - | _ -> raise (Failure "Unreachable") - in - fstar_int_name int_ty ^ "_" ^ binop - -(** A list of keywords/identifiers used in F* and with which we want to check - collision. *) -let fstar_keywords = - let named_unops = - fstar_unop_name Not - :: List.map (fun it -> fstar_unop_name (Neg it)) T.all_signed_int_types - in - let named_binops = [ E.Div; Rem; Add; Sub; Mul ] in - let named_binops = - List.concat - (List.map - (fun bn -> - List.map (fun it -> fstar_named_binop_name bn it) T.all_int_types) - named_binops) - in - let misc = - [ - "let"; - "rec"; - "in"; - "fn"; - "val"; - "int"; - "nat"; - "list"; - "FStar"; - "FStar.Mul"; - "type"; - "match"; - "with"; - "assert"; - "assert_norm"; - "Type0"; - "unit"; - "not"; - "scalar_cast"; - ] - in - List.concat [ named_unops; named_binops; misc ] - -let fstar_assumed_adts : (assumed_ty * string) list = - [ (State, "state"); (Result, "result"); (Option, "option"); (Vec, "vec") ] - -let fstar_assumed_structs : (assumed_ty * string) list = [] - -let fstar_assumed_variants : (assumed_ty * VariantId.id * string) list = - [ - (Result, result_return_id, "Return"); - (Result, result_fail_id, "Fail"); - (Option, option_some_id, "Some"); - (Option, option_none_id, "None"); - ] - -let fstar_assumed_functions : - (A.assumed_fun_id * T.RegionGroupId.id option * string) list = - let rg0 = Some T.RegionGroupId.zero in - [ - (Replace, None, "mem_replace_fwd"); - (Replace, rg0, "mem_replace_back"); - (VecNew, None, "vec_new"); - (VecPush, None, "vec_push_fwd") (* Shouldn't be used *); - (VecPush, rg0, "vec_push_back"); - (VecInsert, None, "vec_insert_fwd") (* Shouldn't be used *); - (VecInsert, rg0, "vec_insert_back"); - (VecLen, None, "vec_len"); - (VecIndex, None, "vec_index_fwd"); - (VecIndex, rg0, "vec_index_back") (* shouldn't be used *); - (VecIndexMut, None, "vec_index_mut_fwd"); - (VecIndexMut, rg0, "vec_index_mut_back"); - ] - -let fstar_names_map_init = - { - keywords = fstar_keywords; - assumed_adts = fstar_assumed_adts; - assumed_structs = fstar_assumed_structs; - assumed_variants = fstar_assumed_variants; - assumed_functions = fstar_assumed_functions; - } - -let fstar_extract_unop (extract_expr : bool -> texpression -> unit) - (fmt : F.formatter) (inside : bool) (unop : unop) (arg : texpression) : unit - = - match unop with - | Not | Neg _ -> - let unop = fstar_unop_name unop in - if inside then F.pp_print_string fmt "("; - F.pp_print_string fmt unop; - F.pp_print_space fmt (); - extract_expr true arg; - if inside then F.pp_print_string fmt ")" - | Cast (src, tgt) -> - (* The source type is an implicit parameter *) - if inside then F.pp_print_string fmt "("; - F.pp_print_string fmt "scalar_cast"; - F.pp_print_space fmt (); - F.pp_print_string fmt - (StringUtils.capitalize_first_letter - (PrintPure.integer_type_to_string src)); - F.pp_print_space fmt (); - F.pp_print_string fmt - (StringUtils.capitalize_first_letter - (PrintPure.integer_type_to_string tgt)); - F.pp_print_space fmt (); - extract_expr true arg; - if inside then F.pp_print_string fmt ")" - -let fstar_extract_binop (extract_expr : bool -> texpression -> unit) - (fmt : F.formatter) (inside : bool) (binop : E.binop) - (int_ty : integer_type) (arg0 : texpression) (arg1 : texpression) : unit = - if inside then F.pp_print_string fmt "("; - (* Some binary operations have a special treatment *) - (match binop with - | Eq | Lt | Le | Ne | Ge | Gt -> - let binop = - match binop with - | Eq -> "=" - | Lt -> "<" - | Le -> "<=" - | Ne -> "<>" - | Ge -> ">=" - | Gt -> ">" - | _ -> raise (Failure "Unreachable") - in - extract_expr false arg0; - F.pp_print_space fmt (); - F.pp_print_string fmt binop; - F.pp_print_space fmt (); - extract_expr false arg1 - | Div | Rem | Add | Sub | Mul -> - let binop = fstar_named_binop_name binop int_ty in - F.pp_print_string fmt binop; - F.pp_print_space fmt (); - extract_expr false arg0; - F.pp_print_space fmt (); - extract_expr false arg1 - | BitXor | BitAnd | BitOr | Shl | Shr -> raise Unimplemented); - if inside then F.pp_print_string fmt ")" - -(** - [ctx]: we use the context to lookup type definitions, to retrieve type names. - This is used to compute variable names, when they have no basenames: in this - case we use the first letter of the type name. - - [variant_concatenate_type_name]: if true, add the type name as a prefix - to the variant names. - Ex.: - In Rust: - {[ - enum List = { - Cons(u32, Box<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/src/FunsAnalysis.ml b/src/FunsAnalysis.ml deleted file mode 100644 index 248ad8b3..00000000 --- a/src/FunsAnalysis.ml +++ /dev/null @@ -1,143 +0,0 @@ -(** Compute various information, including: - - can a function fail (by having `Fail` in its body, or transitively - calling a function which can fail - this is false for globals) - - can a function diverge (by being recursive, containing a loop or - transitively calling a function which can diverge) - - does a function perform stateful operations (i.e., do we need a state - to translate it) - *) - -open LlbcAst -open Crates -module EU = ExpressionsUtils - -type fun_info = { - can_fail : bool; - (* Not used yet: all the extracted functions use an error monad *) - stateful : bool; - divergent : bool; (* Not used yet *) -} -[@@deriving show] -(** Various information about a function. - - Note that not all this information is used yet to adjust the extraction yet. - *) - -type modules_funs_info = fun_info FunDeclId.Map.t -(** Various information about a module's functions *) - -let analyze_module (m : llbc_crate) (funs_map : fun_decl FunDeclId.Map.t) - (globals_map : global_decl GlobalDeclId.Map.t) (use_state : bool) : - modules_funs_info = - let infos = ref FunDeclId.Map.empty in - - let register_info (id : FunDeclId.id) (info : fun_info) : unit = - assert (not (FunDeclId.Map.mem id !infos)); - infos := FunDeclId.Map.add id info !infos - in - - (* Analyze a group of mutually recursive functions. - * As the functions can call each other, we compute the same information - * for all of them (if one of the functions can fail, then all of them - * can fail, etc.). - * - * We simply check if the functions contains panic statements, loop statements, - * recursive calls, etc. We use the previously computed information in case - * of function calls. - *) - let analyze_fun_decls (fun_ids : FunDeclId.Set.t) (d : fun_decl list) : - fun_info = - let can_fail = ref false in - let stateful = ref false in - let divergent = ref false in - - let visit_fun (f : fun_decl) : unit = - let obj = - object (self) - inherit [_] iter_statement as super - method may_fail b = can_fail := !can_fail || b - - method! visit_Assert env a = - self#may_fail true; - super#visit_Assert env a - - method! visit_rvalue _env rv = - match rv with - | Use _ | Ref _ | Discriminant _ | Aggregate _ -> () - | UnaryOp (uop, _) -> can_fail := EU.unop_can_fail uop || !can_fail - | BinaryOp (bop, _, _) -> - can_fail := EU.binop_can_fail bop || !can_fail - - method! visit_Call env call = - (match call.func with - | Regular id -> - if FunDeclId.Set.mem id fun_ids then divergent := true - else - let info = FunDeclId.Map.find id !infos in - self#may_fail info.can_fail; - stateful := !stateful || info.stateful; - divergent := !divergent || info.divergent - | Assumed id -> - (* None of the assumed functions is stateful for now *) - can_fail := !can_fail || Assumed.assumed_can_fail id); - super#visit_Call env call - - method! visit_Panic env = - self#may_fail true; - super#visit_Panic env - - method! visit_Loop env loop = - divergent := true; - super#visit_Loop env loop - end - in - (* Sanity check: global bodies don't contain stateful calls *) - assert ((not f.is_global_decl_body) || not !stateful); - match f.body with - | None -> - (* Opaque function: we consider they fail by default *) - obj#may_fail true; - stateful := (not f.is_global_decl_body) && use_state - | Some body -> obj#visit_statement () body.body - in - List.iter visit_fun d; - (* We need to know if the declaration group contains a global - note that - * groups containing globals contain exactly one declaration *) - let is_global_decl_body = List.exists (fun f -> f.is_global_decl_body) d in - assert ((not is_global_decl_body) || List.length d == 1); - (* We ignore on purpose functions that cannot fail and consider they *can* - * fail: the result of the analysis is not used yet to adjust the translation - * so that the functions which syntactically can't fail don't use an error monad. - * However, we do keep the result of the analysis for global bodies. - * *) - can_fail := (not is_global_decl_body) || !can_fail; - { can_fail = !can_fail; stateful = !stateful; divergent = !divergent } - in - - let analyze_fun_decl_group (d : fun_declaration_group) : unit = - (* Retrieve the function declarations *) - let funs = match d with NonRec id -> [ id ] | Rec ids -> ids in - let funs = List.map (fun id -> FunDeclId.Map.find id funs_map) funs in - let fun_ids = List.map (fun (d : fun_decl) -> d.def_id) funs in - let fun_ids = FunDeclId.Set.of_list fun_ids in - let info = analyze_fun_decls fun_ids funs in - List.iter (fun (f : fun_decl) -> register_info f.def_id info) funs - in - - let rec analyze_decl_groups (decls : declaration_group list) : unit = - match decls with - | [] -> () - | Type _ :: decls' -> analyze_decl_groups decls' - | Fun decl :: decls' -> - analyze_fun_decl_group decl; - analyze_decl_groups decls' - | Global id :: decls' -> - (* Analyze a global by analyzing its body function *) - let global = GlobalDeclId.Map.find id globals_map in - analyze_fun_decl_group (NonRec global.body_id); - analyze_decl_groups decls' - in - - analyze_decl_groups m.declarations; - - !infos diff --git a/src/Identifiers.ml b/src/Identifiers.ml deleted file mode 100644 index b022b18d..00000000 --- a/src/Identifiers.ml +++ /dev/null @@ -1,139 +0,0 @@ -module C = Collections - -(** Signature for a module describing an identifier. - - We often need identifiers (for definitions, variables, etc.) and in - order to make sure we don't mix them, we use a generative functor - (see {!IdGen}). -*) -module type Id = sig - type id - - (** Id generator - simply a counter *) - type generator - - val zero : id - val generator_zero : generator - val generator_from_incr_id : id -> generator - val fresh_stateful_generator : unit -> generator ref * (unit -> id) - val mk_stateful_generator : generator -> generator ref * (unit -> id) - val incr : id -> id - - (* TODO: this should be stateful! - but we may want to be able to duplicate - contexts... - Maybe we could have a [fresh] and a [global_fresh] - TODO: change the order of the returned types - *) - val fresh : generator -> id * generator - val to_string : id -> string - val pp_id : Format.formatter -> id -> unit - val show_id : id -> string - val id_of_json : Yojson.Basic.t -> (id, string) result - val compare_id : id -> id -> int - val max : id -> id -> id - val min : id -> id -> id - val pp_generator : Format.formatter -> generator -> unit - val show_generator : generator -> string - val to_int : id -> int - val of_int : int -> id - val nth : 'a list -> id -> 'a - (* TODO: change the signature (invert the index and the list *) - - val nth_opt : 'a list -> id -> 'a option - - (** Update the nth element of the list. - - Raises [Invalid_argument] if the identifier is out of range. - *) - val update_nth : 'a list -> id -> 'a -> 'a list - - val mapi : (id -> 'a -> 'b) -> 'a list -> 'b list - - (** Same as {!mapi}, but where the indices start with 1. - - TODO: generalize to [map_from_i] - *) - val mapi_from1 : (id -> 'a -> 'b) -> 'a list -> 'b list - - val iteri : (id -> 'a -> unit) -> 'a list -> unit - - module Ord : C.OrderedType with type t = id - module Set : C.Set with type elt = id - module Map : C.Map with type key = id -end - -(** Generative functor for identifiers. - - See {!Id}. -*) -module IdGen () : Id = struct - (* TODO: use Z.t *) - type id = int [@@deriving show] - type generator = id [@@deriving show] - - let zero = 0 - let generator_zero = 0 - - let incr x = - (* Identifiers should never overflow (because max_int is a really big - * value - but we really want to make sure we detect overflows if - * they happen *) - if x = max_int then raise (Errors.IntegerOverflow ()) else x + 1 - - let generator_from_incr_id id = incr id - - let mk_stateful_generator g = - let g = ref g in - let fresh () = - let id = !g in - g := incr id; - id - in - (g, fresh) - - let fresh_stateful_generator () = mk_stateful_generator 0 - let fresh gen = (gen, incr gen) - let to_string = string_of_int - let to_int x = x - let of_int x = x - - let id_of_json js = - (* TODO: check boundaries ? *) - match js with - | `Int i -> Ok i - | _ -> Error ("id_of_json: failed on " ^ Yojson.Basic.show js) - - let compare_id = compare - let max id0 id1 = if id0 > id1 then id0 else id1 - let min id0 id1 = if id0 < id1 then id0 else id1 - let nth v id = List.nth v id - let nth_opt v id = List.nth_opt v id - - let rec update_nth vec id v = - match (vec, id) with - | [], _ -> raise (Invalid_argument "Out of range") - | _ :: vec', 0 -> v :: vec' - | x :: vec', _ -> x :: update_nth vec' (id - 1) v - - let mapi = List.mapi - - let mapi_from1 f ls = - let rec aux i ls = - match ls with [] -> [] | x :: ls' -> f i x :: aux (i + 1) ls' - in - aux 1 ls - - let iteri = List.iteri - - module Ord = struct - type t = id - - let compare = compare - let to_string = to_string - let pp_t = pp_id - let show_t = show_id - end - - module Set = C.MakeSet (Ord) - module Map = C.MakeMap (Ord) -end diff --git a/src/Interpreter.ml b/src/Interpreter.ml deleted file mode 100644 index 7f51c5b9..00000000 --- a/src/Interpreter.ml +++ /dev/null @@ -1,396 +0,0 @@ -open Cps -open InterpreterUtils -open InterpreterProjectors -open InterpreterBorrows -open InterpreterStatements -open LlbcAstUtils -module L = Logging -module T = Types -module A = LlbcAst -module SA = SymbolicAst - -(** The local logger *) -let log = L.interpreter_log - -let compute_type_fun_global_contexts (m : Crates.llbc_crate) : - C.type_context * C.fun_context * C.global_context = - let type_decls_list, _, _ = Crates.split_declarations m.declarations in - let type_decls, fun_decls, global_decls = Crates.compute_defs_maps m in - let type_decls_groups, _funs_defs_groups, _globals_defs_groups = - Crates.split_declarations_to_group_maps m.declarations - in - let type_infos = - TypesAnalysis.analyze_type_declarations type_decls type_decls_list - in - let type_context = { C.type_decls_groups; type_decls; type_infos } in - let fun_context = { C.fun_decls } in - let global_context = { C.global_decls } in - (type_context, fun_context, global_context) - -let initialize_eval_context (type_context : C.type_context) - (fun_context : C.fun_context) (global_context : C.global_context) - (type_vars : T.type_var list) : C.eval_ctx = - C.reset_global_counters (); - { - C.type_context; - C.fun_context; - C.global_context; - C.type_vars; - C.env = [ C.Frame ]; - C.ended_regions = T.RegionId.Set.empty; - } - -(** Initialize an evaluation context to execute a function. - - Introduces local variables initialized in the following manner: - - input arguments are initialized as symbolic values - - the remaining locals are initialized as [⊥] - Abstractions are introduced for the regions present in the function - signature. - - We return: - - the initialized evaluation context - - the list of symbolic values introduced for the input values - - the instantiated function signature - *) -let initialize_symbolic_context_for_fun (type_context : C.type_context) - (fun_context : C.fun_context) (global_context : C.global_context) - (fdef : A.fun_decl) : C.eval_ctx * V.symbolic_value list * A.inst_fun_sig = - (* The abstractions are not initialized the same way as for function - * calls: they contain *loan* projectors, because they "provide" us - * with the input values (which behave as if they had been returned - * by some function calls...). - * Also, note that we properly set the set of parents of every abstraction: - * this should not be necessary, as those abstractions should never be - * *automatically* ended (because ending some borrows requires to end - * one of them), but rather selectively ended when generating code - * for each of the backward functions. We do it only because we can - * do it, and because it gives a bit of sanity. - * *) - let sg = fdef.signature in - (* Create the context *) - let ctx = - initialize_eval_context type_context fun_context global_context - sg.type_params - in - (* Instantiate the signature *) - let type_params = List.map (fun tv -> T.TypeVar tv.T.index) sg.type_params in - let inst_sg = instantiate_fun_sig type_params sg in - (* Create fresh symbolic values for the inputs *) - let input_svs = - List.map (fun ty -> mk_fresh_symbolic_value V.SynthInput ty) inst_sg.inputs - in - (* Initialize the abstractions as empty (i.e., with no avalues) abstractions *) - let call_id = C.fresh_fun_call_id () in - assert (call_id = V.FunCallId.zero); - let compute_abs_avalues (abs : V.abs) (ctx : C.eval_ctx) : - C.eval_ctx * V.typed_avalue list = - (* Project over the values - we use *loan* projectors, as explained above *) - let avalues = - List.map (mk_aproj_loans_value_from_symbolic_value abs.regions) input_svs - in - (ctx, avalues) - in - let region_can_end _ = true in - let ctx = - create_push_abstractions_from_abs_region_groups call_id V.SynthInput - inst_sg.A.regions_hierarchy region_can_end compute_abs_avalues ctx - in - (* Split the variables between return var, inputs and remaining locals *) - let body = Option.get fdef.body in - let ret_var = List.hd body.locals in - let input_vars, local_vars = - Collections.List.split_at (List.tl body.locals) body.arg_count - in - (* Push the return variable (initialized with ⊥) *) - let ctx = C.ctx_push_uninitialized_var ctx ret_var in - (* Push the input variables (initialized with symbolic values) *) - let input_values = List.map mk_typed_value_from_symbolic_value input_svs in - let ctx = C.ctx_push_vars ctx (List.combine input_vars input_values) in - (* Push the remaining local variables (initialized with ⊥) *) - let ctx = C.ctx_push_uninitialized_vars ctx local_vars in - (* Return *) - (ctx, input_svs, inst_sg) - -(** Small helper. - - This is a continuation function called by the symbolic interpreter upon - reaching the [return] instruction when synthesizing a *backward* function: - this continuation takes care of doing the proper manipulations to finish - the synthesis (mostly by ending abstractions). -*) -let evaluate_function_symbolic_synthesize_backward_from_return - (config : C.config) (fdef : A.fun_decl) (inst_sg : A.inst_fun_sig) - (back_id : T.RegionGroupId.id) (ctx : C.eval_ctx) : SA.expression option = - (* We need to instantiate the function signature - to retrieve - * the return type. Note that it is important to re-generate - * an instantiation of the signature, so that we use fresh - * region ids for the return abstractions. *) - let sg = fdef.signature in - let type_params = List.map (fun tv -> T.TypeVar tv.T.index) sg.type_params in - let ret_inst_sg = instantiate_fun_sig type_params sg in - let ret_rty = ret_inst_sg.output in - (* Move the return value out of the return variable *) - let cf_pop_frame = ctx_pop_frame config in - - (* We need to find the parents regions/abstractions of the region we - * will end - this will allow us to, first, mark the other return - * regions as non-endable, and, second, end those parent regions in - * proper order. *) - let parent_rgs = list_parent_region_groups sg back_id in - let parent_input_abs_ids = - T.RegionGroupId.mapi - (fun rg_id rg -> - if T.RegionGroupId.Set.mem rg_id parent_rgs then Some rg.T.id else None) - inst_sg.regions_hierarchy - in - let parent_input_abs_ids = - List.filter_map (fun x -> x) parent_input_abs_ids - in - - (* Insert the return value in the return abstractions (by applying - * borrow projections) *) - let cf_consume_ret ret_value ctx = - let ret_call_id = C.fresh_fun_call_id () in - let compute_abs_avalues (abs : V.abs) (ctx : C.eval_ctx) : - C.eval_ctx * V.typed_avalue list = - let ctx, avalue = - apply_proj_borrows_on_input_value config ctx abs.regions - abs.ancestors_regions ret_value ret_rty - in - (ctx, [ avalue ]) - in - - (* Initialize and insert the abstractions in the context. - * - * We take care of disallowing ending the return regions which we - * shouldn't end (see the documentation of the [can_end] field of [abs] - * for more information. *) - let parent_and_current_rgs = T.RegionGroupId.Set.add back_id parent_rgs in - let region_can_end rid = - T.RegionGroupId.Set.mem rid parent_and_current_rgs - in - assert (region_can_end back_id); - let ctx = - create_push_abstractions_from_abs_region_groups ret_call_id V.SynthRet - ret_inst_sg.A.regions_hierarchy region_can_end compute_abs_avalues ctx - in - - (* We now need to end the proper *input* abstractions - pay attention - * to the fact that we end the *input* abstractions, not the *return* - * abstractions (of course, the corresponding return abstractions will - * automatically be ended, because they consumed values coming from the - * input abstractions...) *) - (* End the parent abstractions and the current abstraction - note that we - * end them in an order which follows the regions hierarchy: it should lead - * to generated code which has a better consistency between the parent - * and children backward functions *) - let current_abs_id = - (T.RegionGroupId.nth inst_sg.regions_hierarchy back_id).id - in - let target_abs_ids = List.append parent_input_abs_ids [ current_abs_id ] in - let cf_end_target_abs cf = - List.fold_left - (fun cf id -> end_abstraction config [] id cf) - cf target_abs_ids - in - (* Generate the Return node *) - let cf_return : m_fun = fun _ -> Some (SA.Return None) in - (* Apply *) - cf_end_target_abs cf_return ctx - in - cf_pop_frame cf_consume_ret ctx - -(** Evaluate a function with the symbolic interpreter. - - We return: - - the list of symbolic values introduced for the input values (this is useful - for the synthesis) - - the symbolic AST generated by the symbolic execution - *) -let evaluate_function_symbolic (config : C.partial_config) (synthesize : bool) - (type_context : C.type_context) (fun_context : C.fun_context) - (global_context : C.global_context) (fdef : A.fun_decl) - (back_id : T.RegionGroupId.id option) : - V.symbolic_value list * SA.expression option = - (* Debug *) - let name_to_string () = - Print.fun_name_to_string fdef.A.name - ^ " (" - ^ Print.option_to_string T.RegionGroupId.to_string back_id - ^ ")" - in - log#ldebug (lazy ("evaluate_function_symbolic: " ^ name_to_string ())); - - (* Create the evaluation context *) - let ctx, input_svs, inst_sg = - initialize_symbolic_context_for_fun type_context fun_context global_context - fdef - in - - (* Create the continuation to finish the evaluation *) - let config = C.config_of_partial C.SymbolicMode config in - let cf_finish res ctx = - match res with - | Return -> - if synthesize then - (* There are two cases: - * - if this is a forward translation, we retrieve the returned value. - * - if this is a backward translation, we introduce "return" - * abstractions to consume the return value, then end all the - * abstractions up to the one in which we are interested. - *) - match back_id with - | None -> - (* Forward translation *) - (* Pop the frame and retrieve the returned value at the same time*) - let cf_pop = ctx_pop_frame config in - (* Generate the Return node *) - let cf_return ret_value : m_fun = - fun _ -> Some (SA.Return (Some ret_value)) - in - (* Apply *) - cf_pop cf_return ctx - | Some back_id -> - (* Backward translation *) - evaluate_function_symbolic_synthesize_backward_from_return config - fdef inst_sg back_id ctx - else None - | Panic -> - (* Note that as we explore all the execution branches, one of - * the executions can lead to a panic *) - if synthesize then Some SA.Panic else None - | _ -> - failwith ("evaluate_function_symbolic failed on: " ^ name_to_string ()) - in - - (* Evaluate the function *) - let symbolic = - eval_function_body config (Option.get fdef.A.body).body cf_finish ctx - in - - (* Return *) - (input_svs, symbolic) - -module Test = struct - (** Test a unit function (taking no arguments) by evaluating it in an empty - environment. - *) - let test_unit_function (config : C.partial_config) (crate : Crates.llbc_crate) - (fid : A.FunDeclId.id) : unit = - (* Retrieve the function declaration *) - let fdef = A.FunDeclId.nth crate.functions fid in - let body = Option.get fdef.body in - - (* Debug *) - log#ldebug - (lazy ("test_unit_function: " ^ Print.fun_name_to_string fdef.A.name)); - - (* Sanity check - *) - assert (List.length fdef.A.signature.region_params = 0); - assert (List.length fdef.A.signature.type_params = 0); - assert (body.A.arg_count = 0); - - (* Create the evaluation context *) - let type_context, fun_context, global_context = - compute_type_fun_global_contexts crate - in - let ctx = - initialize_eval_context type_context fun_context global_context [] - in - - (* Insert the (uninitialized) local variables *) - let ctx = C.ctx_push_uninitialized_vars ctx body.A.locals in - - (* Create the continuation to check the function's result *) - let config = C.config_of_partial C.ConcreteMode config in - let cf_check res ctx = - match res with - | Return -> - (* Ok: drop the local variables and finish *) - ctx_pop_frame config (fun _ _ -> None) ctx - | _ -> - failwith - ("Unit test failed (concrete execution) on: " - ^ Print.fun_name_to_string fdef.A.name) - in - - (* Evaluate the function *) - let _ = eval_function_body config body.body cf_check ctx in - () - - (** Small helper: return true if the function is a *transparent* unit function - (no parameters, no arguments) - TODO: move *) - let fun_decl_is_transparent_unit (def : A.fun_decl) : bool = - match def.body with - | None -> false - | Some body -> - body.arg_count = 0 - && List.length def.A.signature.region_params = 0 - && List.length def.A.signature.type_params = 0 - && List.length def.A.signature.inputs = 0 - - (** Test all the unit functions in a list of function definitions *) - let test_unit_functions (config : C.partial_config) - (crate : Crates.llbc_crate) : unit = - let unit_funs = List.filter fun_decl_is_transparent_unit crate.functions in - let test_unit_fun (def : A.fun_decl) : unit = - test_unit_function config crate def.A.def_id - in - List.iter test_unit_fun unit_funs - - (** Execute the symbolic interpreter on a function. *) - let test_function_symbolic (config : C.partial_config) (synthesize : bool) - (type_context : C.type_context) (fun_context : C.fun_context) - (global_context : C.global_context) (fdef : A.fun_decl) : unit = - (* Debug *) - log#ldebug - (lazy ("test_function_symbolic: " ^ Print.fun_name_to_string fdef.A.name)); - - (* Evaluate *) - let evaluate = - evaluate_function_symbolic config synthesize type_context fun_context - global_context fdef - in - (* Execute the forward function *) - let _ = evaluate None in - (* Execute the backward functions *) - let _ = - T.RegionGroupId.mapi - (fun gid _ -> evaluate (Some gid)) - fdef.signature.regions_hierarchy - in - - () - - (** Small helper *) - let fun_decl_is_transparent (def : A.fun_decl) : bool = - Option.is_some def.body - - (** Execute the symbolic interpreter on a list of functions. - - TODO: for now we ignore the functions which contain loops, because - they are not supported by the symbolic interpreter. - *) - let test_functions_symbolic (config : C.partial_config) (synthesize : bool) - (crate : Crates.llbc_crate) : unit = - (* Filter the functions which contain loops *) - let no_loop_funs = - List.filter - (fun f -> not (LlbcAstUtils.fun_decl_has_loops f)) - crate.functions - in - (* Filter the opaque functions *) - let no_loop_funs = List.filter fun_decl_is_transparent no_loop_funs in - let type_context, fun_context, global_context = - compute_type_fun_global_contexts crate - in - let test_fun (def : A.fun_decl) : unit = - (* Execute the function - note that as the symbolic interpreter explores - * all the path, some executions are expected to "panic": we thus don't - * check the return value *) - test_function_symbolic config synthesize type_context fun_context - global_context def - in - List.iter test_fun no_loop_funs -end diff --git a/src/InterpreterBorrows.ml b/src/InterpreterBorrows.ml deleted file mode 100644 index 30c3b221..00000000 --- a/src/InterpreterBorrows.ml +++ /dev/null @@ -1,1580 +0,0 @@ -module T = Types -module V = Values -module C = Contexts -module Subst = Substitute -module L = Logging -module S = SynthesizeSymbolic -open Cps -open ValuesUtils -open TypesUtils -open InterpreterUtils -open InterpreterBorrowsCore -open InterpreterProjectors - -(** The local logger *) -let log = InterpreterBorrowsCore.log - -(** Auxiliary function to end borrows: lookup a borrow in the environment, - update it (by returning an updated environment where the borrow has been - replaced by {!V.Bottom})) if we can end the borrow (for instance, it is not - an outer borrow...) or return the reason why we couldn't update the borrow. - - [end_borrow] then simply performs a loop: as long as we need to end (outer) - borrows, we end them, before finally ending the borrow we wanted to end in the - first place. - - Note that it is possible to end a borrow in an abstraction, without ending - the whole abstraction, if the corresponding loan is inside the abstraction - as well. The [allowed_abs] parameter controls whether we allow to end borrows - in an abstraction or not, and in which abstraction. -*) -let end_borrow_get_borrow (allowed_abs : V.AbstractionId.id option) - (l : V.BorrowId.id) (ctx : C.eval_ctx) : - (C.eval_ctx * g_borrow_content option, priority_borrows_or_abs) result = - (* We use a reference to communicate the kind of borrow we found, if we - * find one *) - let replaced_bc : g_borrow_content option ref = ref None in - let set_replaced_bc (bc : g_borrow_content) = - assert (Option.is_none !replaced_bc); - replaced_bc := Some bc - in - (* Raise an exception if: - * - there are outer borrows - * - if we are inside an abstraction - * - there are inner loans - * this exception is caught in a wrapper function *) - let raise_if_priority (outer : V.AbstractionId.id option * borrow_ids option) - (borrowed_value : V.typed_value option) = - (* First, look for outer borrows or abstraction *) - let outer_abs, outer_borrows = outer in - (match outer_abs with - | Some abs -> ( - if - (* Check if we can end borrows inside this abstraction *) - Some abs <> allowed_abs - then raise (FoundPriority (OuterAbs abs)) - else - match outer_borrows with - | Some borrows -> raise (FoundPriority (OuterBorrows borrows)) - | None -> ()) - | None -> ( - match outer_borrows with - | Some borrows -> raise (FoundPriority (OuterBorrows borrows)) - | None -> ())); - (* Then check if there are inner loans *) - match borrowed_value with - | None -> () - | Some v -> ( - match get_first_loan_in_value v with - | None -> () - | Some c -> ( - match c with - | V.SharedLoan (bids, _) -> - raise (FoundPriority (InnerLoans (Borrows bids))) - | V.MutLoan bid -> raise (FoundPriority (InnerLoans (Borrow bid))))) - in - - (* The environment is used to keep track of the outer loans *) - let obj = - object - inherit [_] C.map_eval_ctx as super - - (** We reimplement {!visit_Loan} because we may have to update the - outer borrows *) - method! visit_Loan (outer : V.AbstractionId.id option * borrow_ids option) - lc = - match lc with - | V.MutLoan bid -> V.Loan (super#visit_MutLoan outer bid) - | V.SharedLoan (bids, v) -> - (* Update the outer borrows before diving into the shared value *) - let outer = update_outer_borrows outer (Borrows bids) in - V.Loan (super#visit_SharedLoan outer bids v) - - method! visit_Borrow outer bc = - match bc with - | SharedBorrow (_, l') | InactivatedMutBorrow (_, l') -> - (* Check if this is the borrow we are looking for *) - if l = l' then ( - (* Check if there are outer borrows or if we are inside an abstraction *) - raise_if_priority outer None; - (* Register the update *) - set_replaced_bc (Concrete bc); - (* Update the value *) - V.Bottom) - else super#visit_Borrow outer bc - | V.MutBorrow (l', bv) -> - (* Check if this is the borrow we are looking for *) - if l = l' then ( - (* Check if there are outer borrows or if we are inside an abstraction *) - raise_if_priority outer (Some bv); - (* Register the update *) - set_replaced_bc (Concrete bc); - (* Update the value *) - V.Bottom) - else - (* Update the outer borrows before diving into the borrowed value *) - let outer = update_outer_borrows outer (Borrow l') in - V.Borrow (super#visit_MutBorrow outer l' bv) - - (** We reimplement {!visit_ALoan} because we may have to update the - outer borrows *) - method! visit_ALoan outer lc = - (* Note that the children avalues are just other, independent loans, - * so we don't need to update the outer borrows when diving in. - * We keep track of the parents/children relationship only because we - * need it to properly instantiate the backward functions when generating - * the pure translation. *) - match lc with - | V.AMutLoan (_, _) -> - (* Nothing special to do *) - super#visit_ALoan outer lc - | V.ASharedLoan (bids, v, av) -> - (* Explore the shared value - we need to update the outer borrows *) - let souter = update_outer_borrows outer (Borrows bids) in - let v = super#visit_typed_value souter v in - (* Explore the child avalue - we keep the same outer borrows *) - let av = super#visit_typed_avalue outer av in - (* Reconstruct *) - V.ALoan (V.ASharedLoan (bids, v, av)) - | V.AEndedMutLoan { given_back = _; child = _; given_back_meta = _ } - | V.AEndedSharedLoan _ - (* The loan has ended, so no need to update the outer borrows *) - | V.AIgnoredMutLoan _ (* Nothing special to do *) - | V.AEndedIgnoredMutLoan - { given_back = _; child = _; given_back_meta = _ } - (* Nothing special to do *) - | V.AIgnoredSharedLoan _ -> - (* Nothing special to do *) - super#visit_ALoan outer lc - - method! visit_ABorrow outer bc = - match bc with - | V.AMutBorrow (_, bid, _) -> - (* Check if this is the borrow we are looking for *) - if bid = l then ( - (* When ending a mut borrow, there are two cases: - * - in the general case, we have to end the whole abstraction - * (and thus raise an exception to signal that to the caller) - * - in some situations, the associated loan is inside the same - * abstraction as the borrow. In this situation, we can end - * the borrow without ending the whole abstraction, and we - * simply move the child avalue around. - *) - (* Check there are outer borrows, or if we need to end the whole - * abstraction *) - raise_if_priority outer None; - (* Register the update *) - set_replaced_bc (Abstract bc); - (* Update the value - note that we are necessarily in the second - * of the two cases described above. - * Also note that, as we are moving the borrowed value inside the - * abstraction (and not really giving the value back to the context) - * we do not insert {!AEndedMutBorrow} but rather {!ABottom} *) - V.ABottom) - else - (* Update the outer borrows before diving into the child avalue *) - let outer = update_outer_borrows outer (Borrow bid) in - super#visit_ABorrow outer bc - | V.ASharedBorrow bid -> - (* Check if this is the borrow we are looking for *) - if bid = l then ( - (* Check there are outer borrows, or if we need to end the whole - * abstraction *) - raise_if_priority outer None; - (* Register the update *) - set_replaced_bc (Abstract bc); - (* Update the value - note that we are necessarily in the second - * of the two cases described above *) - V.ABottom) - else super#visit_ABorrow outer bc - | V.AIgnoredMutBorrow (_, _) - | V.AEndedMutBorrow _ - | V.AEndedIgnoredMutBorrow - { given_back_loans_proj = _; child = _; given_back_meta = _ } - | V.AEndedSharedBorrow -> - (* Nothing special to do *) - super#visit_ABorrow outer bc - | V.AProjSharedBorrow asb -> - (* Check if the borrow we are looking for is in the asb *) - if borrow_in_asb l asb then ( - (* Check there are outer borrows, or if we need to end the whole - * abstraction *) - raise_if_priority outer None; - (* Register the update *) - set_replaced_bc (Abstract bc); - (* Update the value - note that we are necessarily in the second - * of the two cases described above *) - let asb = remove_borrow_from_asb l asb in - V.ABorrow (V.AProjSharedBorrow asb)) - else (* Nothing special to do *) - super#visit_ABorrow outer bc - - method! visit_abs outer abs = - (* Update the outer abs *) - let outer_abs, outer_borrows = outer in - assert (Option.is_none outer_abs); - assert (Option.is_none outer_borrows); - let outer = (Some abs.V.abs_id, None) in - super#visit_abs outer abs - end - in - (* Catch the exceptions - raised if there are outer borrows *) - try - let ctx = obj#visit_eval_ctx (None, None) ctx in - Ok (ctx, !replaced_bc) - with FoundPriority outers -> Error outers - -(** Auxiliary function to end borrows. See [give_back]. - - When we end a mutable borrow, we need to "give back" the value it contained - to its original owner by reinserting it at the proper position. - - Note that this function checks that there is exactly one loan to which we - give the value back. - TODO: this was not the case before, so some sanity checks are not useful anymore. - *) -let give_back_value (config : C.config) (bid : V.BorrowId.id) - (nv : V.typed_value) (ctx : C.eval_ctx) : C.eval_ctx = - (* Sanity check *) - assert (not (loans_in_value nv)); - assert (not (bottom_in_value ctx.ended_regions nv)); - (* Debug *) - log#ldebug - (lazy - ("give_back_value:\n- bid: " ^ V.BorrowId.to_string bid ^ "\n- value: " - ^ typed_value_to_string ctx nv - ^ "\n- context:\n" ^ eval_ctx_to_string ctx ^ "\n")); - (* We use a reference to check that we updated exactly one loan *) - let replaced : bool ref = ref false in - let set_replaced () = - assert (not !replaced); - replaced := true - in - (* Whenever giving back symbolic values, they shouldn't contain already ended regions *) - let check_symbolic_no_ended = true in - (* We sometimes need to reborrow values while giving a value back due: prepare that *) - let allow_reborrows = true in - let fresh_reborrow, apply_registered_reborrows = - prepare_reborrows config allow_reborrows - in - (* The visitor to give back the values *) - let obj = - object (self) - inherit [_] C.map_eval_ctx as super - - (** This is a bit annoying, but as we need the type of the value we - are exploring, for sanity checks, we need to implement - {!visit_typed_avalue} instead of - overriding {!visit_ALoan} *) - method! visit_typed_value opt_abs (v : V.typed_value) : V.typed_value = - match v.V.value with - | V.Loan lc -> - let value = self#visit_typed_Loan opt_abs v.V.ty lc in - ({ v with V.value } : V.typed_value) - | _ -> super#visit_typed_value opt_abs v - - method visit_typed_Loan opt_abs ty lc = - match lc with - | V.SharedLoan (bids, v) -> - (* We are giving back a value (i.e., the content of a *mutable* - * borrow): nothing special to do *) - V.Loan (super#visit_SharedLoan opt_abs bids v) - | V.MutLoan bid' -> - (* Check if this is the loan we are looking for *) - if bid' = bid then ( - (* Sanity check *) - let expected_ty = ty in - if nv.V.ty <> expected_ty then ( - log#serror - ("give_back_value: improper type:\n- expected: " - ^ ety_to_string ctx ty ^ "\n- received: " - ^ ety_to_string ctx nv.V.ty); - failwith "Value given back doesn't have the proper type"); - (* Replace *) - set_replaced (); - nv.V.value) - else V.Loan (super#visit_MutLoan opt_abs bid') - - (** This is a bit annoying, but as we need the type of the avalue we - are exploring, in order to be able to project the value we give - back, we need to reimplement {!visit_typed_avalue} instead of - {!visit_ALoan} *) - method! visit_typed_avalue opt_abs (av : V.typed_avalue) : V.typed_avalue - = - match av.V.value with - | V.ALoan lc -> - let value = self#visit_typed_ALoan opt_abs av.V.ty lc in - ({ av with V.value } : V.typed_avalue) - | _ -> super#visit_typed_avalue opt_abs av - - (** We need to inspect ignored mutable borrows, to insert loan projectors - if necessary. - *) - method! visit_ABorrow (opt_abs : V.abs option) (bc : V.aborrow_content) - : V.avalue = - match bc with - | V.AIgnoredMutBorrow (bid', child) -> - if bid' = Some bid then - (* Insert a loans projector - note that if this case happens, - * it is necessarily because we ended a parent abstraction, - * and the given back value is thus a symbolic value *) - match nv.V.value with - | V.Symbolic sv -> - let abs = Option.get opt_abs in - (* Remember the given back value as a meta-value - * TODO: it is a bit annoying to have to deconstruct - * the value... Think about a more elegant way. *) - let given_back_meta = as_symbolic nv.value in - (* The loan projector *) - let given_back_loans_proj = - mk_aproj_loans_value_from_symbolic_value abs.regions sv - in - (* Continue giving back in the child value *) - let child = super#visit_typed_avalue opt_abs child in - (* Return *) - V.ABorrow - (V.AEndedIgnoredMutBorrow - { given_back_loans_proj; child; given_back_meta }) - | _ -> failwith "Unreachable" - else - (* Continue exploring *) - V.ABorrow (super#visit_AIgnoredMutBorrow opt_abs bid' child) - | _ -> - (* Continue exploring *) - super#visit_ABorrow opt_abs bc - - (** We are not specializing an already existing method, but adding a - new method (for projections, we need type information) *) - method visit_typed_ALoan (opt_abs : V.abs option) (ty : T.rty) - (lc : V.aloan_content) : V.avalue = - (* Preparing a bit *) - let regions, ancestors_regions = - match opt_abs with - | None -> failwith "Unreachable" - | Some abs -> (abs.V.regions, abs.V.ancestors_regions) - in - (* Rk.: there is a small issue with the types of the aloan values. - * See the comment at the level of definition of {!typed_avalue} *) - let borrowed_value_aty = - let _, ty, _ = ty_get_ref ty in - ty - in - match lc with - | V.AMutLoan (bid', child) -> - if bid' = bid then ( - (* This is the loan we are looking for: apply the projection to - * the value we give back and replaced this mutable loan with - * an ended loan *) - (* Register the insertion *) - set_replaced (); - (* Remember the given back value as a meta-value *) - let given_back_meta = nv in - (* Apply the projection *) - let given_back = - apply_proj_borrows check_symbolic_no_ended ctx fresh_reborrow - regions ancestors_regions nv borrowed_value_aty - in - (* Continue giving back in the child value *) - let child = super#visit_typed_avalue opt_abs child in - (* Return the new value *) - V.ALoan (V.AEndedMutLoan { child; given_back; given_back_meta })) - else (* Continue exploring *) - super#visit_ALoan opt_abs lc - | V.ASharedLoan (_, _, _) -> - (* We are giving back a value to a *mutable* loan: nothing special to do *) - super#visit_ALoan opt_abs lc - | V.AEndedMutLoan { child = _; given_back = _; given_back_meta = _ } - | V.AEndedSharedLoan (_, _) -> - (* Nothing special to do *) - super#visit_ALoan opt_abs lc - | V.AIgnoredMutLoan (bid', child) -> - (* This loan is ignored, but we may have to project on a subvalue - * of the value which is given back *) - if bid' = bid then - (* Remember the given back value as a meta-value *) - let given_back_meta = nv in - (* Note that we replace the ignored mut loan by an *ended* ignored - * mut loan. Also, this is not the loan we are looking for *per se*: - * we don't register the fact that we inserted the value somewhere - * (i.e., we don't call {!set_replaced}) *) - let given_back = - apply_proj_borrows check_symbolic_no_ended ctx fresh_reborrow - regions ancestors_regions nv borrowed_value_aty - in - (* Continue giving back in the child value *) - let child = super#visit_typed_avalue opt_abs child in - V.ALoan - (V.AEndedIgnoredMutLoan { given_back; child; given_back_meta }) - else super#visit_ALoan opt_abs lc - | V.AEndedIgnoredMutLoan - { given_back = _; child = _; given_back_meta = _ } - | V.AIgnoredSharedLoan _ -> - (* Nothing special to do *) - super#visit_ALoan opt_abs lc - - method! visit_Abs opt_abs abs = - (* We remember in which abstraction we are before diving - - * this is necessary for projecting values: we need to know - * over which regions to project *) - assert (Option.is_none opt_abs); - super#visit_Abs (Some abs) abs - end - in - - (* Explore the environment *) - let ctx = obj#visit_eval_ctx None ctx in - (* Check we gave back to exactly one loan *) - assert !replaced; - (* Apply the reborrows *) - apply_registered_reborrows ctx - -(** Give back a *modified* symbolic value. *) -let give_back_symbolic_value (_config : C.config) - (proj_regions : T.RegionId.Set.t) (proj_ty : T.rty) (sv : V.symbolic_value) - (nsv : V.symbolic_value) (ctx : C.eval_ctx) : C.eval_ctx = - (* Sanity checks *) - assert (sv.sv_id <> nsv.sv_id); - (match nsv.sv_kind with - | V.SynthInputGivenBack | V.SynthRetGivenBack | V.FunCallGivenBack -> () - | V.FunCallRet | V.SynthInput | V.Global -> failwith "Unrechable"); - (* Store the given-back value as a meta-value for synthesis purposes *) - let mv = nsv in - (* Substitution function, to replace the borrow projectors over symbolic values *) - let subst (_abs : V.abs) local_given_back = - (* See the below comments: there is something wrong here *) - let _ = raise Errors.Unimplemented in - (* Compute the projection over the given back value *) - let child_proj = - match nsv.sv_kind with - | V.SynthRetGivenBack -> - (* The given back value comes from the return value of the function - we are currently synthesizing (as it is given back, it means - we ended one of the regions appearing in the signature: we are - currently synthesizing one of the backward functions). - - As we don't allow borrow overwrites on returned value, we can - (and MUST) forget the borrows *) - V.AIgnoredProjBorrows - | V.FunCallGivenBack -> - (* TODO: there is something wrong here. - Consider this: - {[ - abs0 {'a} { AProjLoans (s0 : &'a mut T) [] } - abs1 {'b} { AProjBorrows (s0 : &'a mut T <: &'b mut T) } - ]} - - Upon ending abs1, we give back some fresh symbolic value [s1], - that we reinsert where the loan for [s0] is. However, the mutable - borrow in the type [&'a mut T] was ended: we give back a value of - type [T]! We thus *mustn't* introduce a projector here. - *) - V.AProjBorrows (nsv, sv.V.sv_ty) - | _ -> failwith "Unreachable" - in - V.AProjLoans (sv, (mv, child_proj) :: local_given_back) - in - update_intersecting_aproj_loans proj_regions proj_ty sv subst ctx - -(** Auxiliary function to end borrows. See [give_back]. - - This function is similar to {!give_back_value} but gives back an {!V.avalue} - (coming from an abstraction). - - It is used when ending a borrow inside an abstraction, when the corresponding - loan is inside the same abstraction (in which case we don't need to end the whole - abstraction). - - REMARK: this function can't be used to give back the values borrowed by - end abstraction when ending this abstraction. When doing this, we need - to convert the {!V.avalue} to a {!type:V.value} by introducing the proper symbolic values. - *) -let give_back_avalue_to_same_abstraction (_config : C.config) - (bid : V.BorrowId.id) (mv : V.mvalue) (nv : V.typed_avalue) - (ctx : C.eval_ctx) : C.eval_ctx = - (* We use a reference to check that we updated exactly one loan *) - let replaced : bool ref = ref false in - let set_replaced () = - assert (not !replaced); - replaced := true - in - let obj = - object (self) - inherit [_] C.map_eval_ctx as super - - (** This is a bit annoying, but as we need the type of the avalue we - are exploring, in order to be able to project the value we give - back, we need to reimplement {!visit_typed_avalue} instead of - {!visit_ALoan} *) - method! visit_typed_avalue opt_abs (av : V.typed_avalue) : V.typed_avalue - = - match av.V.value with - | V.ALoan lc -> - let value = self#visit_typed_ALoan opt_abs av.V.ty lc in - ({ av with V.value } : V.typed_avalue) - | _ -> super#visit_typed_avalue opt_abs av - - (** We are not specializing an already existing method, but adding a - new method (for projections, we need type information) *) - method visit_typed_ALoan (opt_abs : V.abs option) (ty : T.rty) - (lc : V.aloan_content) : V.avalue = - match lc with - | V.AMutLoan (bid', child) -> - if bid' = bid then ( - (* Sanity check - about why we need to call {!ty_get_ref} - * (and don't do the same thing as in {!give_back_value}) - * see the comment at the level of the definition of - * {!typed_avalue} *) - let _, expected_ty, _ = ty_get_ref ty in - if nv.V.ty <> expected_ty then ( - log#serror - ("give_back_avalue_to_same_abstraction: improper type:\n\ - - expected: " ^ rty_to_string ctx ty ^ "\n- received: " - ^ rty_to_string ctx nv.V.ty); - failwith "Value given back doesn't have the proper type"); - (* This is the loan we are looking for: apply the projection to - * the value we give back and replaced this mutable loan with - * an ended loan *) - (* Register the insertion *) - set_replaced (); - (* Return the new value *) - V.ALoan - (V.AEndedMutLoan - { given_back = nv; child; given_back_meta = mv })) - else (* Continue exploring *) - super#visit_ALoan opt_abs lc - | V.ASharedLoan (_, _, _) - (* We are giving back a value to a *mutable* loan: nothing special to do *) - | V.AEndedMutLoan { given_back = _; child = _; given_back_meta = _ } - | V.AEndedSharedLoan (_, _) -> - (* Nothing special to do *) - super#visit_ALoan opt_abs lc - | V.AIgnoredMutLoan (bid', child) -> - (* This loan is ignored, but we may have to project on a subvalue - * of the value which is given back *) - if bid' = bid then ( - (* Note that we replace the ignored mut loan by an *ended* ignored - * mut loan. Also, this is not the loan we are looking for *per se*: - * we don't register the fact that we inserted the value somewhere - * (i.e., we don't call {!set_replaced}) *) - (* Sanity check *) - assert (nv.V.ty = ty); - V.ALoan - (V.AEndedIgnoredMutLoan - { given_back = nv; child; given_back_meta = mv })) - else super#visit_ALoan opt_abs lc - | V.AEndedIgnoredMutLoan - { given_back = _; child = _; given_back_meta = _ } - | V.AIgnoredSharedLoan _ -> - (* Nothing special to do *) - super#visit_ALoan opt_abs lc - end - in - - (* Explore the environment *) - let ctx = obj#visit_eval_ctx None ctx in - (* Check we gave back to exactly one loan *) - assert !replaced; - (* Return *) - ctx - -(** Auxiliary function to end borrows. See [give_back]. - - When we end a shared borrow, we need to remove the borrow id from the list - of borrows to the shared value. - - Note that this function checks that there is exactly one shared loan that - we update. - TODO: this was not the case before, so some sanity checks are not useful anymore. - *) -let give_back_shared _config (bid : V.BorrowId.id) (ctx : C.eval_ctx) : - C.eval_ctx = - (* We use a reference to check that we updated exactly one loan *) - let replaced : bool ref = ref false in - let set_replaced () = - assert (not !replaced); - replaced := true - in - let obj = - object - inherit [_] C.map_eval_ctx as super - - method! visit_Loan opt_abs lc = - match lc with - | V.SharedLoan (bids, shared_value) -> - if V.BorrowId.Set.mem bid bids then ( - (* This is the loan we are looking for *) - set_replaced (); - (* If there remains exactly one borrow identifier, we need - * to end the loan. Otherwise, we just remove the current - * loan identifier *) - if V.BorrowId.Set.cardinal bids = 1 then shared_value.V.value - else - V.Loan - (V.SharedLoan (V.BorrowId.Set.remove bid bids, shared_value))) - else - (* Not the loan we are looking for: continue exploring *) - V.Loan (super#visit_SharedLoan opt_abs bids shared_value) - | V.MutLoan bid' -> - (* We are giving back a *shared* borrow: nothing special to do *) - V.Loan (super#visit_MutLoan opt_abs bid') - - method! visit_ALoan opt_abs lc = - match lc with - | V.AMutLoan (bid, av) -> - (* Nothing special to do (we are giving back a *shared* borrow) *) - V.ALoan (super#visit_AMutLoan opt_abs bid av) - | V.ASharedLoan (bids, shared_value, child) -> - if V.BorrowId.Set.mem bid bids then ( - (* This is the loan we are looking for *) - set_replaced (); - (* If there remains exactly one borrow identifier, we need - * to end the loan. Otherwise, we just remove the current - * loan identifier *) - if V.BorrowId.Set.cardinal bids = 1 then - V.ALoan (V.AEndedSharedLoan (shared_value, child)) - else - V.ALoan - (V.ASharedLoan - (V.BorrowId.Set.remove bid bids, shared_value, child))) - else - (* Not the loan we are looking for: continue exploring *) - super#visit_ALoan opt_abs lc - | V.AEndedMutLoan { given_back = _; child = _; given_back_meta = _ } - (* Nothing special to do (the loan has ended) *) - | V.AEndedSharedLoan (_, _) - (* Nothing special to do (the loan has ended) *) - | V.AIgnoredMutLoan (_, _) - (* Nothing special to do (we are giving back a *shared* borrow) *) - | V.AEndedIgnoredMutLoan - { given_back = _; child = _; given_back_meta = _ } - (* Nothing special to do *) - | V.AIgnoredSharedLoan _ -> - (* Nothing special to do *) - super#visit_ALoan opt_abs lc - end - in - - (* Explore the environment *) - let ctx = obj#visit_eval_ctx None ctx in - (* Check we gave back to exactly one loan *) - assert !replaced; - (* Return *) - ctx - -(** When copying values, we duplicate the shared borrows. This is tantamount - to reborrowing the shared value. The following function applies this change - to an environment by inserting a new borrow id in the set of borrows tracked - by a shared value, referenced by the [original_bid] argument. - *) -let reborrow_shared (original_bid : V.BorrowId.id) (new_bid : V.BorrowId.id) - (ctx : C.eval_ctx) : C.eval_ctx = - (* Keep track of changes *) - let r = ref false in - let set_ref () = - assert (not !r); - r := true - in - - let obj = - object - inherit [_] C.map_env as super - - method! visit_SharedLoan env bids sv = - (* Shared loan: check if the borrow id we are looking for is in the - set of borrow ids. If yes, insert the new borrow id, otherwise - explore inside the shared value *) - if V.BorrowId.Set.mem original_bid bids then ( - set_ref (); - let bids' = V.BorrowId.Set.add new_bid bids in - V.SharedLoan (bids', sv)) - else super#visit_SharedLoan env bids sv - - method! visit_ASharedLoan env bids v av = - (* This case is similar to the {!SharedLoan} case *) - if V.BorrowId.Set.mem original_bid bids then ( - set_ref (); - let bids' = V.BorrowId.Set.add new_bid bids in - V.ASharedLoan (bids', v, av)) - else super#visit_ASharedLoan env bids v av - end - in - - let env = obj#visit_env () ctx.env in - (* Check that we reborrowed once *) - assert !r; - { ctx with env } - -(** Auxiliary function: see [end_borrow] *) -let give_back (config : C.config) (l : V.BorrowId.id) (bc : g_borrow_content) - (ctx : C.eval_ctx) : C.eval_ctx = - (* Debug *) - log#ldebug - (lazy - (let bc = - match bc with - | Concrete bc -> borrow_content_to_string ctx bc - | Abstract bc -> aborrow_content_to_string ctx bc - in - "give_back:\n- bid: " ^ V.BorrowId.to_string l ^ "\n- content: " ^ bc - ^ "\n- context:\n" ^ eval_ctx_to_string ctx ^ "\n")); - (* This is used for sanity checks *) - let sanity_ek = - { enter_shared_loans = true; enter_mut_borrows = true; enter_abs = true } - in - match bc with - | Concrete (V.MutBorrow (l', tv)) -> - (* Sanity check *) - assert (l' = l); - assert (not (loans_in_value tv)); - (* Check that the corresponding loan is somewhere - purely a sanity check *) - assert (Option.is_some (lookup_loan_opt sanity_ek l ctx)); - (* Update the context *) - give_back_value config l tv ctx - | Concrete (V.SharedBorrow (_, l') | V.InactivatedMutBorrow (_, l')) -> - (* Sanity check *) - assert (l' = l); - (* Check that the borrow is somewhere - purely a sanity check *) - assert (Option.is_some (lookup_loan_opt sanity_ek l ctx)); - (* Update the context *) - give_back_shared config l ctx - | Abstract (V.AMutBorrow (mv, l', av)) -> - (* Sanity check *) - assert (l' = l); - (* Check that the corresponding loan is somewhere - purely a sanity check *) - assert (Option.is_some (lookup_loan_opt sanity_ek l ctx)); - (* Update the context *) - give_back_avalue_to_same_abstraction config l mv av ctx - | Abstract (V.ASharedBorrow l') -> - (* Sanity check *) - assert (l' = l); - (* Check that the borrow is somewhere - purely a sanity check *) - assert (Option.is_some (lookup_loan_opt sanity_ek l ctx)); - (* Update the context *) - give_back_shared config l ctx - | Abstract (V.AProjSharedBorrow asb) -> - (* Sanity check *) - assert (borrow_in_asb l asb); - (* Update the context *) - give_back_shared config l ctx - | Abstract - ( V.AEndedMutBorrow _ | V.AIgnoredMutBorrow _ | V.AEndedIgnoredMutBorrow _ - | V.AEndedSharedBorrow ) -> - failwith "Unreachable" - -(** Convert an {!type:V.avalue} to a {!type:V.value}. - - This function is used when ending abstractions: whenever we end a borrow - in an abstraction, we converted the borrowed {!V.avalue} to a fresh symbolic - {!type:V.value}, then give back this {!type:V.value} to the context. - - Note that some regions may have ended in the symbolic value we generate. - For instance, consider the following function signature: - {[ - fn f<'a>(x : &'a mut &'a mut u32); - ]} - When ending the abstraction, the value given back for the outer borrow - should be ⊥. In practice, we will give back a symbolic value which can't - be expanded (because expanding this symbolic value would require expanding - a reference whose region has already ended). - *) -let convert_avalue_to_given_back_value (abs_kind : V.abs_kind) - (av : V.typed_avalue) : V.symbolic_value = - let sv_kind = - match abs_kind with - | V.FunCall -> V.FunCallGivenBack - | V.SynthRet -> V.SynthRetGivenBack - | V.SynthInput -> V.SynthInputGivenBack - in - mk_fresh_symbolic_value sv_kind av.V.ty - -(** End a borrow identified by its borrow id in a context. - - Rk.: from now onwards, the functions are written in continuation passing style. - The reason is that when ending borrows we may end abstractions, which results - in synthesized code. - - First lookup the borrow in the context and replace it with {!V.Bottom}. - Then, check that there is an associated loan in the context. When moving - values, before putting the value in its destination, we get an - intermediate state where some values are "outside" the context and thus - inaccessible. As {!give_back_value} just performs a map for instance (TODO: - not the case anymore), we need to check independently that there is indeed a - loan ready to receive the value we give back (note that we also have other - invariants like: there is exacly one mutable loan associated to a mutable - borrow, etc. but they are more easily maintained). - Note that in theory, we shouldn't never reach a problematic state as the - one we describe above, because when we move a value we need to end all the - loans inside before moving it. Still, it is a very useful sanity check. - Finally, give the values back. - - Of course, we end outer borrows before updating the target borrow if it - proves necessary. - If a borrow is inside an abstraction, we need to end the whole abstraction, - at the exception of the case where the loan corresponding to the borrow is - inside the same abstraction. We control this with the [allowed_abs] parameter: - if it is not [None], we allow ending a borrow if it is inside the given - abstraction. In practice, if the value is [Some abs_id], we should have - checked that the corresponding loan is inside the abstraction given by - [abs_id] before. In practice, only {!end_borrow} should call itself - with [allowed_abs = Some ...], all the other calls should use [allowed_abs = None]: - if you look ath the implementation details, [end_borrow] performs - all tne necessary checks in case a borrow is inside an abstraction. - TODO: we shouldn't allow this last case (end a borrow when the corresponding - loan is in the same abstraction). - - TODO: we should split this function in two: one function which doesn't - perform anything smart and is trusted, and another function for the - book-keeping. - *) -let rec end_borrow (config : C.config) (chain : borrow_or_abs_ids) - (allowed_abs : V.AbstractionId.id option) (l : V.BorrowId.id) : cm_fun = - fun cf ctx -> - (* Check that we don't loop *) - let chain0 = chain in - let chain = add_borrow_or_abs_id_to_chain "end_borrow: " (BorrowId l) chain in - log#ldebug - (lazy - ("end borrow: " ^ V.BorrowId.to_string l ^ ":\n- original context:\n" - ^ eval_ctx_to_string ctx)); - - (* Utility function for the sanity checks: check that the borrow disappeared - * from the context *) - let ctx0 = ctx in - let check_disappeared (ctx : C.eval_ctx) : unit = - let _ = - match lookup_borrow_opt ek_all l ctx with - | None -> () (* Ok *) - | Some _ -> - log#lerror - (lazy - ("end borrow: " ^ V.BorrowId.to_string l - ^ ": borrow didn't disappear:\n- original context:\n" - ^ eval_ctx_to_string ctx0 ^ "\n\n- new context:\n" - ^ eval_ctx_to_string ctx)); - failwith "Borrow not eliminated" - in - match lookup_loan_opt ek_all l ctx with - | None -> () (* Ok *) - | Some _ -> - log#lerror - (lazy - ("end borrow: " ^ V.BorrowId.to_string l - ^ ": loan didn't disappear:\n- original context:\n" - ^ eval_ctx_to_string ctx0 ^ "\n\n- new context:\n" - ^ eval_ctx_to_string ctx)); - failwith "Loan not eliminated" - in - let cf_check_disappeared : cm_fun = unit_to_cm_fun check_disappeared in - (* The complete sanity check: also check that after we ended a borrow, - * the invariant is preserved *) - let cf_check : cm_fun = - comp cf_check_disappeared (Invariants.cf_check_invariants config) - in - - (* Start by getting the borrow *) - match end_borrow_get_borrow allowed_abs l ctx with - (* Two cases: - * - error: we found outer borrows or inner loans (end them first) - * - success: we didn't find outer borrows when updating (but maybe we actually - didn't find the borrow we were looking for...) - *) - | Error priority -> ( - (* Debug *) - log#ldebug - (lazy - ("end borrow: " ^ V.BorrowId.to_string l - ^ ": found outer borrows/abs or inner loans:" - ^ show_priority_borrows_or_abs priority)); - (* End the priority borrows, abstraction, then try again to end the target - * borrow (if necessary) *) - match priority with - | OuterBorrows (Borrows bids) | InnerLoans (Borrows bids) -> - (* Note that we might get there with [allowed_abs <> None]: we might - * be trying to end a borrow inside an abstraction, but which is actually - * inside another borrow *) - let allowed_abs' = None in - (* End the outer borrows *) - let cc = end_borrows config chain allowed_abs' bids in - (* Retry to end the borrow *) - let cc = comp cc (end_borrow config chain0 allowed_abs l) in - (* Check and apply *) - comp cc cf_check cf ctx - | OuterBorrows (Borrow bid) | InnerLoans (Borrow bid) -> - let allowed_abs' = None in - (* End the outer borrow *) - let cc = end_borrow config chain allowed_abs' bid in - (* Retry to end the borrow *) - let cc = comp cc (end_borrow config chain0 allowed_abs l) in - (* Check and apply *) - comp cc cf_check cf ctx - | OuterAbs abs_id -> - (* The borrow is inside an asbtraction: check if the corresponding - * loan is inside the same abstraction. If this is the case, we end - * the borrow without ending the abstraction. If not, we need to - * end the whole abstraction *) - (* Note that we can lookup the loan anywhere *) - let ek = - { - enter_shared_loans = true; - enter_mut_borrows = true; - enter_abs = true; - } - in - let cf_end_abs : cm_fun = - match lookup_loan ek l ctx with - | AbsId loan_abs_id, _ -> - if loan_abs_id = abs_id then - (* Same abstraction! We can end the borrow *) - end_borrow config chain0 (Some abs_id) l - else - (* Not the same abstraction: we need to end the whole abstraction. - * By doing that we should have ended the target borrow (see the - * below sanity check) *) - end_abstraction config chain abs_id - | VarId _, _ -> - (* The loan is not inside the same abstraction (actually inside - * a non-abstraction value): we need to end the whole abstraction *) - end_abstraction config chain abs_id - in - (* Compose with a sanity check *) - comp cf_end_abs cf_check cf ctx) - | Ok (ctx, None) -> - log#ldebug (lazy "End borrow: borrow not found"); - (* It is possible that we can't find a borrow in symbolic mode (ending - * an abstraction may end several borrows at once *) - assert (config.mode = SymbolicMode); - (* Do a sanity check and continue *) - cf_check cf ctx - (* We found a borrow: give it back (i.e., update the corresponding loan) *) - | Ok (ctx, Some bc) -> - (* Sanity check: the borrowed value shouldn't contain loans *) - (match bc with - | Concrete (V.MutBorrow (_, bv)) -> - assert (Option.is_none (get_first_loan_in_value bv)) - | _ -> ()); - (* Give back the value *) - let ctx = give_back config l bc ctx in - (* Do a sanity check and continue *) - cf_check cf ctx - -and end_borrows (config : C.config) (chain : borrow_or_abs_ids) - (allowed_abs : V.AbstractionId.id option) (lset : V.BorrowId.Set.t) : cm_fun - = - fun cf -> - (* This is not necessary, but we prefer to reorder the borrow ids, - * so that we actually end from the smallest id to the highest id - just - * a matter of taste, and may make debugging easier *) - let ids = V.BorrowId.Set.fold (fun id ids -> id :: ids) lset [] in - List.fold_left (fun cf id -> end_borrow config chain allowed_abs id cf) cf ids - -and end_abstraction (config : C.config) (chain : borrow_or_abs_ids) - (abs_id : V.AbstractionId.id) : cm_fun = - fun cf ctx -> - (* Check that we don't loop *) - let chain = - add_borrow_or_abs_id_to_chain "end_abstraction: " (AbsId abs_id) chain - in - (* Remember the original context for printing purposes *) - let ctx0 = ctx in - log#ldebug - (lazy - ("end_abstraction: " - ^ V.AbstractionId.to_string abs_id - ^ "\n- original context:\n" ^ eval_ctx_to_string ctx0)); - - (* Lookup the abstraction *) - let abs = C.ctx_lookup_abs ctx abs_id in - - (* Check that we can end the abstraction *) - assert abs.can_end; - - (* End the parent abstractions first *) - let cc = end_abstractions config chain abs.parents in - let cc = - comp_unit cc (fun ctx -> - log#ldebug - (lazy - ("end_abstraction: " - ^ V.AbstractionId.to_string abs_id - ^ "\n- context after parent abstractions ended:\n" - ^ eval_ctx_to_string ctx))) - in - - (* End the loans inside the abstraction *) - let cc = comp cc (end_abstraction_loans config chain abs_id) in - let cc = - comp_unit cc (fun ctx -> - log#ldebug - (lazy - ("end_abstraction: " - ^ V.AbstractionId.to_string abs_id - ^ "\n- context after loans ended:\n" ^ eval_ctx_to_string ctx))) - in - - (* End the abstraction itself by redistributing the borrows it contains *) - let cc = comp cc (end_abstraction_borrows config chain abs_id) in - - (* End the regions owned by the abstraction - note that we don't need to - * relookup the abstraction: the set of regions in an abstraction never - * changes... *) - let cc = - comp_update cc (fun ctx -> - let ended_regions = - T.RegionId.Set.union ctx.ended_regions abs.V.regions - in - { ctx with ended_regions }) - in - - (* Remove all the references to the id of the current abstraction, and remove - * the abstraction itself. - * **Rk.**: this is where we synthesize the updated symbolic AST *) - let cc = comp cc (end_abstraction_remove_from_context config abs_id) in - - (* Debugging *) - let cc = - comp_unit cc (fun ctx -> - log#ldebug - (lazy - ("end_abstraction: " - ^ V.AbstractionId.to_string abs_id - ^ "\n- original context:\n" ^ eval_ctx_to_string ctx0 - ^ "\n\n- new context:\n" ^ eval_ctx_to_string ctx))) - in - - (* Sanity check: ending an abstraction must preserve the invariants *) - let cc = comp cc (Invariants.cf_check_invariants config) in - - (* Apply the continuation *) - cc cf ctx - -and end_abstractions (config : C.config) (chain : borrow_or_abs_ids) - (abs_ids : V.AbstractionId.Set.t) : cm_fun = - fun cf -> - (* This is not necessary, but we prefer to reorder the abstraction ids, - * so that we actually end from the smallest id to the highest id - just - * a matter of taste, and may make debugging easier *) - let abs_ids = V.AbstractionId.Set.fold (fun id ids -> id :: ids) abs_ids [] in - List.fold_left (fun cf id -> end_abstraction config chain id cf) cf abs_ids - -and end_abstraction_loans (config : C.config) (chain : borrow_or_abs_ids) - (abs_id : V.AbstractionId.id) : cm_fun = - fun cf ctx -> - (* Lookup the abstraction *) - let abs = C.ctx_lookup_abs ctx abs_id in - (* End the first loan we find. - * - * We ignore the "ignored mut/shared loans": as we should have already ended - * the parent abstractions, they necessarily come from children. *) - let opt_loan = get_first_non_ignored_aloan_in_abstraction abs in - match opt_loan with - | None -> - (* No loans: nothing to update *) - cf ctx - | Some (BorrowIds bids) -> - (* There are loans: end the corresponding borrows, then recheck *) - let cc : cm_fun = - match bids with - | Borrow bid -> end_borrow config chain None bid - | Borrows bids -> end_borrows config chain None bids - in - (* Reexplore, looking for loans *) - let cc = comp cc (end_abstraction_loans config chain abs_id) in - (* Continue *) - cc cf ctx - | Some (SymbolicValue sv) -> - (* There is a proj_loans over a symbolic value: end the proj_borrows - * which intersect this proj_loans, then end the proj_loans itself *) - let cc = end_proj_loans_symbolic config chain abs_id abs.regions sv in - (* Reexplore, looking for loans *) - let cc = comp cc (end_abstraction_loans config chain abs_id) in - (* Continue *) - cc cf ctx - -and end_abstraction_borrows (config : C.config) (chain : borrow_or_abs_ids) - (abs_id : V.AbstractionId.id) : cm_fun = - fun cf ctx -> - log#ldebug - (lazy - ("end_abstraction_borrows: abs_id: " ^ V.AbstractionId.to_string abs_id)); - (* Note that the abstraction mustn't contain any loans *) - (* We end the borrows, starting with the *inner* ones. This is important - when considering nested borrows which have the same lifetime. - TODO: is that really important? Initially, there was a concern about - whether we should give back ⊥ or not, but everything is handled by - the symbolic value expansion... Also, now we use the AEndedMutBorrow - values to store the children avalues (which was not the case before - we - initially replaced the ended mut borrows with ⊥). - *) - (* We explore in-depth and use exceptions. When exploring a borrow, if - * the exploration didn't trigger an exception, it means there are no - * inner borrows to end: we can thus trigger an exception for the current - * borrow. *) - let obj = - object - inherit [_] V.iter_abs as super - - method! visit_aborrow_content env bc = - (* In-depth exploration *) - super#visit_aborrow_content env bc; - (* No exception was raise: we can raise an exception for the - * current borrow *) - match bc with - | V.AMutBorrow (_, _, _) | V.ASharedBorrow _ -> - (* Raise an exception *) - raise (FoundABorrowContent bc) - | V.AProjSharedBorrow asb -> - (* Raise an exception only if the asb contains borrows *) - if - List.exists - (fun x -> match x with V.AsbBorrow _ -> true | _ -> false) - asb - then raise (FoundABorrowContent bc) - else () - | V.AEndedMutBorrow _ | V.AIgnoredMutBorrow _ - | V.AEndedIgnoredMutBorrow _ | V.AEndedSharedBorrow -> - (* Nothing to do for ignored borrows *) - () - - method! visit_aproj env sproj = - (match sproj with - | V.AProjLoans _ -> failwith "Unexpected" - | V.AProjBorrows (sv, proj_ty) -> - raise (FoundAProjBorrows (sv, proj_ty)) - | V.AEndedProjLoans _ | V.AEndedProjBorrows _ | V.AIgnoredProjBorrows -> - ()); - super#visit_aproj env sproj - - (** We may need to end borrows in "regular" values, because of shared values *) - method! visit_borrow_content _ bc = - match bc with - | V.SharedBorrow (_, _) | V.MutBorrow (_, _) -> - raise (FoundBorrowContent bc) - | V.InactivatedMutBorrow _ -> failwith "Unreachable" - end - in - (* Lookup the abstraction *) - let abs = C.ctx_lookup_abs ctx abs_id in - try - (* Explore the abstraction, looking for borrows *) - obj#visit_abs () abs; - (* No borrows: nothing to update *) - cf ctx - with - (* There are concrete (i.e., not symbolic) borrows: end them, then reexplore *) - | FoundABorrowContent bc -> - log#ldebug - (lazy - ("end_abstraction_borrows: found aborrow content: " - ^ aborrow_content_to_string ctx bc)); - let ctx = - match bc with - | V.AMutBorrow (_mv, bid, av) -> - (* First, convert the avalue to a (fresh symbolic) value *) - let sv = convert_avalue_to_given_back_value abs.kind av in - (* Replace the mut borrow to register the fact that we ended - * it and store with it the freshly generated given back value *) - let ended_borrow = V.ABorrow (V.AEndedMutBorrow (sv, av)) in - let ctx = update_aborrow ek_all bid ended_borrow ctx in - (* Give the value back *) - let sv = mk_typed_value_from_symbolic_value sv in - give_back_value config bid sv ctx - | V.ASharedBorrow bid -> - (* Replace the shared borrow to account for the fact it ended *) - let ended_borrow = V.ABorrow V.AEndedSharedBorrow in - let ctx = update_aborrow ek_all bid ended_borrow ctx in - (* Give back *) - give_back_shared config bid ctx - | V.AProjSharedBorrow asb -> - (* Retrieve the borrow ids *) - let bids = - List.filter_map - (fun asb -> - match asb with - | V.AsbBorrow bid -> Some bid - | V.AsbProjReborrows (_, _) -> None) - asb - in - (* There should be at least one borrow identifier in the set, which we - * can use to identify the whole set *) - let repr_bid = List.hd bids in - (* Replace the shared borrow with Bottom *) - let ctx = update_aborrow ek_all repr_bid V.ABottom ctx in - (* Give back the shared borrows *) - let ctx = - List.fold_left - (fun ctx bid -> give_back_shared config bid ctx) - ctx bids - in - (* Continue *) - ctx - | V.AEndedMutBorrow _ | V.AIgnoredMutBorrow _ - | V.AEndedIgnoredMutBorrow _ | V.AEndedSharedBorrow -> - failwith "Unexpected" - in - (* Reexplore *) - end_abstraction_borrows config chain abs_id cf ctx - (* There are symbolic borrows: end them, then reexplore *) - | FoundAProjBorrows (sv, proj_ty) -> - log#ldebug - (lazy - ("end_abstraction_borrows: found aproj borrows: " - ^ aproj_to_string ctx (V.AProjBorrows (sv, proj_ty)))); - (* Generate a fresh symbolic value *) - let nsv = mk_fresh_symbolic_value V.FunCallGivenBack proj_ty in - (* Replace the proj_borrows - there should be exactly one *) - let ended_borrow = V.AEndedProjBorrows nsv in - let ctx = update_aproj_borrows abs.abs_id sv ended_borrow ctx in - (* Give back the symbolic value *) - let ctx = - give_back_symbolic_value config abs.regions proj_ty sv nsv ctx - in - (* Reexplore *) - end_abstraction_borrows config chain abs_id cf ctx - (* There are concrete (i.e., not symbolic) borrows in shared values: end them, then reexplore *) - | FoundBorrowContent bc -> - log#ldebug - (lazy - ("end_abstraction_borrows: found borrow content: " - ^ borrow_content_to_string ctx bc)); - let ctx = - match bc with - | V.SharedBorrow (_, bid) -> ( - (* Replace the shared borrow with bottom *) - match end_borrow_get_borrow (Some abs_id) bid ctx with - | Error _ -> failwith "Unreachable" - | Ok (ctx, _) -> - (* Give back *) - give_back_shared config bid ctx) - | V.MutBorrow (bid, v) -> ( - (* Replace the mut borrow with bottom *) - match end_borrow_get_borrow (Some abs_id) bid ctx with - | Error _ -> failwith "Unreachable" - | Ok (ctx, _) -> - (* Give the value back - note that the mut borrow was below a - * shared borrow: the value is thus unchanged *) - give_back_value config bid v ctx) - | V.InactivatedMutBorrow _ -> failwith "Unreachable" - in - (* Reexplore *) - end_abstraction_borrows config chain abs_id cf ctx - -(** Remove an abstraction from the context, as well as all its references *) -and end_abstraction_remove_from_context (_config : C.config) - (abs_id : V.AbstractionId.id) : cm_fun = - fun cf ctx -> - let rec remove_from_env (env : C.env) : C.env * V.abs option = - match env with - | [] -> failwith "Unreachable" - | C.Frame :: _ -> (env, None) - | Var (bv, v) :: env -> - let env, abs_opt = remove_from_env env in - (Var (bv, v) :: env, abs_opt) - | C.Abs abs :: env -> - if abs.abs_id = abs_id then (env, Some abs) - else - let env, abs_opt = remove_from_env env in - let parents = V.AbstractionId.Set.remove abs_id abs.parents in - (C.Abs { abs with V.parents } :: env, abs_opt) - in - let env, abs = remove_from_env ctx.C.env in - let ctx = { ctx with C.env } in - let abs = Option.get abs in - (* Apply the continuation *) - let expr = cf ctx in - (* Synthesize the symbolic AST *) - S.synthesize_end_abstraction abs expr - -(** End a proj_loan over a symbolic value by ending the proj_borrows which - intersect this proj_loans. - - Rk.: - - if this symbolic value is primitively copiable, then: - - either proj_borrows are only present in the concrete context - - or there is only one intersecting proj_borrow present in an - abstraction - - otherwise, this symbolic value is not primitively copiable: - - there may be proj_borrows_shared over this value - - if we put aside the proj_borrows_shared, there should be exactly one - intersecting proj_borrows, either in the concrete context or in an - abstraction -*) -and end_proj_loans_symbolic (config : C.config) (chain : borrow_or_abs_ids) - (abs_id : V.AbstractionId.id) (regions : T.RegionId.Set.t) - (sv : V.symbolic_value) : cm_fun = - fun cf ctx -> - (* Small helpers for sanity checks *) - let check ctx = no_aproj_over_symbolic_in_context sv ctx in - let cf_check (cf : m_fun) : m_fun = - fun ctx -> - check ctx; - cf ctx - in - (* Find the first proj_borrows which intersects the proj_loans *) - let explore_shared = true in - match lookup_intersecting_aproj_borrows_opt explore_shared regions sv ctx with - | None -> - (* We couldn't find any in the context: it means that the symbolic value - * is in the concrete environment (or that we dropped it, in which case - * it is completely absent). We thus simply need to replace the loans - * projector with an ended projector. *) - let ctx = update_aproj_loans_to_ended abs_id sv ctx in - (* Sanity check *) - check ctx; - (* Continue *) - cf ctx - | Some (SharedProjs projs) -> - (* We found projectors over shared values - split between the projectors - which belong to the current abstraction and the others. - The context looks like this: - {[ - abs'0 { - // The loan was initially like this: - // [shared_loan lids (s <: ...) [s]] - // but if we get there it means it was already ended: - ended_shared_loan (s <: ...) [s] - proj_shared_borrows [...; (s <: ...); ...] - proj_shared_borrows [...; (s <: ...); ...] - ... - } - - abs'1 [ - proj_shared_borrows [...; (s <: ...); ...] - ... - } - - ... - - // No [s] outside of abstractions - - ]} - *) - let _owned_projs, external_projs = - List.partition (fun (abs_id', _) -> abs_id' = abs_id) projs - in - (* End the external borrow projectors (end their abstractions) *) - let cf_end_external : cm_fun = - fun cf ctx -> - let abs_ids = List.map fst external_projs in - let abs_ids = - List.fold_left - (fun s id -> V.AbstractionId.Set.add id s) - V.AbstractionId.Set.empty abs_ids - in - (* End the abstractions and continue *) - end_abstractions config chain abs_ids cf ctx - in - (* End the internal borrows projectors and the loans projector *) - let cf_end_internal : cm_fun = - fun cf ctx -> - (* All the proj_borrows are owned: simply erase them *) - let ctx = remove_intersecting_aproj_borrows_shared regions sv ctx in - (* End the loan itself *) - let ctx = update_aproj_loans_to_ended abs_id sv ctx in - (* Sanity check *) - check ctx; - (* Continue *) - cf ctx - in - (* Compose and apply *) - let cc = comp cf_end_external cf_end_internal in - cc cf ctx - | Some (NonSharedProj (abs_id', _proj_ty)) -> - (* We found one projector of borrows in an abstraction: if it comes - * from this abstraction, we can end it directly, otherwise we need - * to end the abstraction where it came from first *) - if abs_id' = abs_id then ( - (* Note that it happens when a function returns a [&mut ...] which gets - expanded to [mut_borrow l s], and we end the borrow [l] (so [s] gets - reinjected in the parent abstraction without having been modified). - - The context looks like this: - {[ - abs'0 { - [s <: ...] - (s <: ...) - } - - // Note that [s] can't appear in other abstractions or in the - // regular environment (because we forbid the duplication of - // symbolic values which contain borrows). - ]} - *) - (* End the projector of borrows - TODO: not completely sure what to - * replace it with... Maybe we should introduce an ABottomProj? *) - let ctx = update_aproj_borrows abs_id sv V.AIgnoredProjBorrows ctx in - (* Sanity check: no other occurrence of an intersecting projector of borrows *) - assert ( - Option.is_none - (lookup_intersecting_aproj_borrows_opt explore_shared regions sv ctx)); - (* End the projector of loans *) - let ctx = update_aproj_loans_to_ended abs_id sv ctx in - (* Sanity check *) - check ctx; - (* Continue *) - cf ctx) - else - (* The borrows proj comes from a different abstraction: end it. *) - let cc = end_abstraction config chain abs_id' in - (* Retry ending the projector of loans *) - let cc = - comp cc (end_proj_loans_symbolic config chain abs_id regions sv) - in - (* Sanity check *) - let cc = comp cc cf_check in - (* Continue *) - cc cf ctx - -let end_outer_borrow config : V.BorrowId.id -> cm_fun = - end_borrow config [] None - -let end_outer_borrows config : V.BorrowId.Set.t -> cm_fun = - end_borrows config [] None - -(** Helper function: see [activate_inactivated_mut_borrow]. - - This function updates the shared loan to a mutable loan (we then update - the borrow with another helper). Of course, the shared loan must contain - exactly one borrow id (the one we give as parameter), otherwise we can't - promote it. Also, the shared value mustn't contain any loan. - - The returned value (previously shared) is checked: - - it mustn't contain loans - - it mustn't contain {!V.Bottom} - - it mustn't contain inactivated borrows - TODO: this kind of checks should be put in an auxiliary helper, because - they are redundant. - - The loan to update mustn't be a borrowed value. - *) -let promote_shared_loan_to_mut_loan (l : V.BorrowId.id) - (cf : V.typed_value -> m_fun) : m_fun = - fun ctx -> - (* Debug *) - log#ldebug - (lazy - ("promote_shared_loan_to_mut_loan:\n- loan: " ^ V.BorrowId.to_string l - ^ "\n- context:\n" ^ eval_ctx_to_string ctx ^ "\n")); - (* Lookup the shared loan - note that we can't promote a shared loan - * in a shared value, but we can do it in a mutably borrowed value. - * This is important because we can do: [let y = &two-phase ( *x );] - *) - let ek = - { enter_shared_loans = false; enter_mut_borrows = true; enter_abs = false } - in - match lookup_loan ek l ctx with - | _, Concrete (V.MutLoan _) -> - failwith "Expected a shared loan, found a mut loan" - | _, Concrete (V.SharedLoan (bids, sv)) -> - (* Check that there is only one borrow id (l) and update the loan *) - assert (V.BorrowId.Set.mem l bids && V.BorrowId.Set.cardinal bids = 1); - (* We need to check that there aren't any loans in the value: - we should have gotten rid of those already, but it is better - to do a sanity check. *) - assert (not (loans_in_value sv)); - (* Check there isn't {!Bottom} (this is actually an invariant *) - assert (not (bottom_in_value ctx.ended_regions sv)); - (* Check there aren't inactivated borrows *) - assert (not (inactivated_in_value sv)); - (* Update the loan content *) - let ctx = update_loan ek l (V.MutLoan l) ctx in - (* Continue *) - cf sv ctx - | _, Abstract _ -> - (* I don't think it is possible to have two-phase borrows involving borrows - * returned by abstractions. I'm not sure how we could handle that anyway. *) - failwith - "Can't promote a shared loan to a mutable loan if the loan is inside \ - an abstraction" - -(** Helper function: see {!activate_inactivated_mut_borrow}. - - This function updates a shared borrow to a mutable borrow. - *) -let promote_inactivated_borrow_to_mut_borrow (l : V.BorrowId.id) (cf : m_fun) - (borrowed_value : V.typed_value) : m_fun = - fun ctx -> - (* Lookup the inactivated borrow - note that we don't go inside borrows/loans: - there can't be inactivated borrows inside other borrows/loans - *) - let ek = - { enter_shared_loans = false; enter_mut_borrows = false; enter_abs = false } - in - let ctx = - match lookup_borrow ek l ctx with - | Concrete (V.SharedBorrow _ | V.MutBorrow (_, _)) -> - failwith "Expected an inactivated mutable borrow" - | Concrete (V.InactivatedMutBorrow _) -> - (* Update it *) - update_borrow ek l (V.MutBorrow (l, borrowed_value)) ctx - | Abstract _ -> - (* This can't happen for sure *) - failwith - "Can't promote a shared borrow to a mutable borrow if the borrow is \ - inside an abstraction" - in - (* Continue *) - cf ctx - -(** Promote an inactivated mut borrow to a mut borrow. - - The borrow must point to a shared value which is borrowed exactly once. - *) -let rec activate_inactivated_mut_borrow (config : C.config) (l : V.BorrowId.id) - : cm_fun = - fun cf ctx -> - (* Lookup the value *) - let ek = - { enter_shared_loans = false; enter_mut_borrows = true; enter_abs = false } - in - match lookup_loan ek l ctx with - | _, Concrete (V.MutLoan _) -> failwith "Unreachable" - | _, Concrete (V.SharedLoan (bids, sv)) -> ( - (* If there are loans inside the value, end them. Note that there can't be - inactivated borrows inside the value. - If we perform an update, do a recursive call to lookup the updated value *) - match get_first_loan_in_value sv with - | Some lc -> - (* End the loans *) - let cc = - match lc with - | V.SharedLoan (bids, _) -> end_outer_borrows config bids - | V.MutLoan bid -> end_outer_borrow config bid - in - (* Recursive call *) - let cc = comp cc (activate_inactivated_mut_borrow config l) in - (* Continue *) - cc cf ctx - | None -> - (* No loan to end inside the value *) - (* Some sanity checks *) - log#ldebug - (lazy - ("activate_inactivated_mut_borrow: resulting value:\n" - ^ typed_value_to_string ctx sv)); - assert (not (loans_in_value sv)); - assert (not (bottom_in_value ctx.ended_regions sv)); - assert (not (inactivated_in_value sv)); - (* End the borrows which borrow from the value, at the exception of - the borrow we want to promote *) - let bids = V.BorrowId.Set.remove l bids in - let cc = end_outer_borrows config bids in - (* Promote the loan - TODO: this will fail if the value contains - * any loans. In practice, it shouldn't, but we could also - * look for loans inside the value and end them before promoting - * the borrow. *) - let cc = comp cc (promote_shared_loan_to_mut_loan l) in - (* Promote the borrow - the value should have been checked by - {!promote_shared_loan_to_mut_loan} - *) - let cc = - comp cc (fun cf borrowed_value -> - promote_inactivated_borrow_to_mut_borrow l cf borrowed_value) - in - (* Continue *) - cc cf ctx) - | _, Abstract _ -> - (* I don't think it is possible to have two-phase borrows involving borrows - * returned by abstractions. I'm not sure how we could handle that anyway. *) - failwith - "Can't activate an inactivated mutable borrow referencing a loan inside\n\ - \ an abstraction" diff --git a/src/InterpreterBorrowsCore.ml b/src/InterpreterBorrowsCore.ml deleted file mode 100644 index a5501712..00000000 --- a/src/InterpreterBorrowsCore.ml +++ /dev/null @@ -1,1181 +0,0 @@ -(* This file defines the basic blocks to implement the semantics of borrows. - * Note that those functions are not only used in InterpreterBorrows, but - * also in Invariants or InterpreterProjectors *) - -module T = Types -module V = Values -module C = Contexts -module Subst = Substitute -module L = Logging -open Utils -open TypesUtils -open InterpreterUtils - -(** The local logger *) -let log = L.borrows_log - -(** TODO: cleanup this a bit, once we have a better understanding about - what we need. - TODO: I'm not sure in which file this should be moved... *) -type exploration_kind = { - enter_shared_loans : bool; - enter_mut_borrows : bool; - enter_abs : bool; - (** Note that if we allow to enter abs, we don't check whether we enter - mutable/shared loans or borrows: there are no use cases requiring - a finer control. *) -} -(** This record controls how some generic helper lookup/update - functions behave, by restraining the kind of therms they can enter. -*) - -let ek_all : exploration_kind = - { enter_shared_loans = true; enter_mut_borrows = true; enter_abs = true } - -type borrow_ids = Borrows of V.BorrowId.Set.t | Borrow of V.BorrowId.id -[@@deriving show] - -exception FoundBorrowIds of borrow_ids - -type priority_borrows_or_abs = - | OuterBorrows of borrow_ids - | OuterAbs of V.AbstractionId.id - | InnerLoans of borrow_ids -[@@deriving show] - -type borrow_ids_or_symbolic_value = - | BorrowIds of borrow_ids - | SymbolicValue of V.symbolic_value -[@@deriving show] - -let update_if_none opt x = match opt with None -> Some x | _ -> opt - -(** Utility exception *) -exception FoundPriority of priority_borrows_or_abs - -type loan_or_borrow_content = - | LoanContent of V.loan_content - | BorrowContent of V.borrow_content -[@@deriving show] - -type borrow_or_abs_id = - | BorrowId of V.BorrowId.id - | AbsId of V.AbstractionId.id - -type borrow_or_abs_ids = borrow_or_abs_id list - -let borrow_or_abs_id_to_string (id : borrow_or_abs_id) : string = - match id with - | AbsId id -> "abs@" ^ V.AbstractionId.to_string id - | BorrowId id -> "l@" ^ V.BorrowId.to_string id - -let borrow_or_abs_ids_chain_to_string (ids : borrow_or_abs_ids) : string = - let ids = List.rev ids in - let ids = List.map borrow_or_abs_id_to_string ids in - String.concat " -> " ids - -(** Add a borrow or abs id to a chain of ids, while checking that we don't loop *) -let add_borrow_or_abs_id_to_chain (msg : string) (id : borrow_or_abs_id) - (ids : borrow_or_abs_ids) : borrow_or_abs_ids = - if List.mem id ids then - failwith - (msg ^ "detected a loop in the chain of ids: " - ^ borrow_or_abs_ids_chain_to_string (id :: ids)) - else id :: ids - -(** Helper function. - - This function allows to define in a generic way a comparison of region types. - See [projections_interesect] for instance. - - [default]: default boolean to return, when comparing types with no regions - [combine]: how to combine booleans - [compare_regions]: how to compare regions - *) -let rec compare_rtys (default : bool) (combine : bool -> bool -> bool) - (compare_regions : T.RegionId.id T.region -> T.RegionId.id T.region -> bool) - (ty1 : T.rty) (ty2 : T.rty) : bool = - let compare = compare_rtys default combine compare_regions in - match (ty1, ty2) with - | T.Bool, T.Bool | T.Char, T.Char | T.Str, T.Str -> default - | T.Integer int_ty1, T.Integer int_ty2 -> - assert (int_ty1 = int_ty2); - default - | T.Adt (id1, regions1, tys1), T.Adt (id2, regions2, tys2) -> - assert (id1 = id2); - - (* The check for the ADTs is very crude: we simply compare the arguments - * two by two. - * - * For instance, when checking if some projections intersect, we simply - * check if some arguments intersect. As all the type and region - * parameters should be used somewhere in the ADT (otherwise rustc - * generates an error), it means that it should be equivalent to checking - * whether two fields intersect (and anyway comparing the field types is - * difficult in case of enumerations...). - * If we didn't have the above property enforced by the rust compiler, - * this check would still be a reasonable conservative approximation. *) - - (* Check the region parameters *) - let regions = List.combine regions1 regions2 in - let params_b = - List.fold_left - (fun b (r1, r2) -> combine b (compare_regions r1 r2)) - default regions - in - (* Check the type parameters *) - let tys = List.combine tys1 tys2 in - let tys_b = - List.fold_left - (fun b (ty1, ty2) -> combine b (compare ty1 ty2)) - default tys - in - (* Combine *) - combine params_b tys_b - | T.Array ty1, T.Array ty2 | T.Slice ty1, T.Slice ty2 -> compare ty1 ty2 - | T.Ref (r1, ty1, kind1), T.Ref (r2, ty2, kind2) -> - (* Sanity check *) - assert (kind1 = kind2); - (* Explanation for the case where we check if projections intersect: - * the projections intersect if the borrows intersect or their contents - * intersect. *) - let regions_b = compare_regions r1 r2 in - let tys_b = compare ty1 ty2 in - combine regions_b tys_b - | T.TypeVar id1, T.TypeVar id2 -> - assert (id1 = id2); - default - | _ -> - log#lerror - (lazy - ("compare_rtys: unexpected inputs:" ^ "\n- ty1: " ^ T.show_rty ty1 - ^ "\n- ty2: " ^ T.show_rty ty2)); - failwith "Unreachable" - -(** Check if two different projections intersect. This is necessary when - giving a symbolic value to an abstraction: we need to check that - the regions which are already ended inside the abstraction don't - intersect the regions over which we project in the new abstraction. - Note that the two abstractions have different views (in terms of regions) - of the symbolic value (hence the two region types). -*) -let projections_intersect (ty1 : T.rty) (rset1 : T.RegionId.Set.t) (ty2 : T.rty) - (rset2 : T.RegionId.Set.t) : bool = - let default = false in - let combine b1 b2 = b1 || b2 in - let compare_regions r1 r2 = - region_in_set r1 rset1 && region_in_set r2 rset2 - in - compare_rtys default combine compare_regions ty1 ty2 - -(** Check if the first projection contains the second projection. - We use this function when checking invariants. -*) -let projection_contains (ty1 : T.rty) (rset1 : T.RegionId.Set.t) (ty2 : T.rty) - (rset2 : T.RegionId.Set.t) : bool = - let default = true in - let combine b1 b2 = b1 && b2 in - let compare_regions r1 r2 = - region_in_set r1 rset1 || not (region_in_set r2 rset2) - in - compare_rtys default combine compare_regions ty1 ty2 - -(** Lookup a loan content. - - The loan is referred to by a borrow id. - - TODO: group abs_or_var_id and g_loan_content. - *) -let lookup_loan_opt (ek : exploration_kind) (l : V.BorrowId.id) - (ctx : C.eval_ctx) : (abs_or_var_id * g_loan_content) option = - (* We store here whether we are inside an abstraction or a value - note that we - * could also track that with the environment, it would probably be more idiomatic - * and cleaner *) - let abs_or_var : abs_or_var_id option ref = ref None in - - let obj = - object - inherit [_] C.iter_eval_ctx as super - - method! visit_borrow_content env bc = - match bc with - | V.SharedBorrow (mv, bid) -> - (* Nothing specific to do *) - super#visit_SharedBorrow env mv bid - | V.InactivatedMutBorrow (mv, bid) -> - (* Nothing specific to do *) - super#visit_InactivatedMutBorrow env mv bid - | V.MutBorrow (bid, mv) -> - (* Control the dive *) - if ek.enter_mut_borrows then super#visit_MutBorrow env bid mv - else () - - (** We reimplement {!visit_Loan} (rather than the more precise functions - {!visit_SharedLoan}, etc.) on purpose: as we have an exhaustive match - below, we are more resilient to definition updates (the compiler - is our friend). - *) - method! visit_loan_content env lc = - match lc with - | V.SharedLoan (bids, sv) -> - (* Check if this is the loan we are looking for, and control the dive *) - if V.BorrowId.Set.mem l bids then - raise (FoundGLoanContent (Concrete lc)) - else if ek.enter_shared_loans then - super#visit_SharedLoan env bids sv - else () - | V.MutLoan bid -> - (* Check if this is the loan we are looking for *) - if bid = l then raise (FoundGLoanContent (Concrete lc)) - else super#visit_MutLoan env bid - - (** Note that we don't control diving inside the abstractions: if we - allow to dive inside abstractions, we allow to go anywhere - (because there are no use cases requiring finer control) *) - method! visit_aloan_content env lc = - match lc with - | V.AMutLoan (bid, av) -> - if bid = l then raise (FoundGLoanContent (Abstract lc)) - else super#visit_AMutLoan env bid av - | V.ASharedLoan (bids, v, av) -> - if V.BorrowId.Set.mem l bids then - raise (FoundGLoanContent (Abstract lc)) - else super#visit_ASharedLoan env bids v av - | V.AEndedMutLoan { given_back = _; child = _; given_back_meta = _ } - | V.AEndedSharedLoan (_, _) - | V.AIgnoredMutLoan (_, _) - | V.AEndedIgnoredMutLoan - { given_back = _; child = _; given_back_meta = _ } - | V.AIgnoredSharedLoan _ -> - super#visit_aloan_content env lc - - method! visit_Var env bv v = - assert (Option.is_none !abs_or_var); - abs_or_var := - Some - (VarId (match bv with Some bv -> Some bv.C.index | None -> None)); - super#visit_Var env bv v; - abs_or_var := None - - method! visit_Abs env abs = - assert (Option.is_none !abs_or_var); - if ek.enter_abs then ( - abs_or_var := Some (AbsId abs.V.abs_id); - super#visit_Abs env abs; - abs_or_var := None) - else () - end - in - (* We use exceptions *) - try - obj#visit_eval_ctx () ctx; - None - with FoundGLoanContent lc -> ( - match !abs_or_var with - | Some abs_or_var -> Some (abs_or_var, lc) - | None -> raise (Failure "Inconsistent state")) - -(** Lookup a loan content. - - The loan is referred to by a borrow id. - Raises an exception if no loan was found. - *) -let lookup_loan (ek : exploration_kind) (l : V.BorrowId.id) (ctx : C.eval_ctx) : - abs_or_var_id * g_loan_content = - match lookup_loan_opt ek l ctx with - | None -> failwith "Unreachable" - | Some res -> res - -(** Update a loan content. - - The loan is referred to by a borrow id. - - This is a helper function: it might break invariants. - *) -let update_loan (ek : exploration_kind) (l : V.BorrowId.id) - (nlc : V.loan_content) (ctx : C.eval_ctx) : C.eval_ctx = - (* We use a reference to check that we update exactly one loan: when updating - * inside values, we check we don't update more than one loan. Then, upon - * returning we check that we updated at least once. *) - let r = ref false in - let update () : V.loan_content = - assert (not !r); - r := true; - nlc - in - - let obj = - object - inherit [_] C.map_eval_ctx as super - - method! visit_borrow_content env bc = - match bc with - | V.SharedBorrow (_, _) | V.InactivatedMutBorrow _ -> - (* Nothing specific to do *) - super#visit_borrow_content env bc - | V.MutBorrow (bid, mv) -> - (* Control the dive into mutable borrows *) - if ek.enter_mut_borrows then super#visit_MutBorrow env bid mv - else V.MutBorrow (bid, mv) - - (** We reimplement {!visit_loan_content} (rather than one of the sub- - functions) on purpose: exhaustive matches are good for maintenance *) - method! visit_loan_content env lc = - match lc with - | V.SharedLoan (bids, sv) -> - (* Shared loan: check if this is the loan we are looking for, and - control the dive. *) - if V.BorrowId.Set.mem l bids then update () - else if ek.enter_shared_loans then - super#visit_SharedLoan env bids sv - else V.SharedLoan (bids, sv) - | V.MutLoan bid -> - (* Mut loan: checks if this is the loan we are looking for *) - if bid = l then update () else super#visit_MutLoan env bid - - (** Note that once inside the abstractions, we don't control diving - (there are no use cases requiring finer control). - Also, as we give back a {!loan_content} (and not an {!aloan_content}) - we don't need to do reimplement the visit functions for the values - inside the abstractions (rk.: there may be "concrete" values inside - abstractions, so there is a utility in diving inside). *) - method! visit_abs env abs = - if ek.enter_abs then super#visit_abs env abs else abs - end - in - - let ctx = obj#visit_eval_ctx () ctx in - (* Check that we updated at least one loan *) - assert !r; - ctx - -(** Update a abstraction loan content. - - The loan is referred to by a borrow id. - - This is a helper function: it might break invariants. - *) -let update_aloan (ek : exploration_kind) (l : V.BorrowId.id) - (nlc : V.aloan_content) (ctx : C.eval_ctx) : C.eval_ctx = - (* We use a reference to check that we update exactly one loan: when updating - * inside values, we check we don't update more than one loan. Then, upon - * returning we check that we updated at least once. *) - let r = ref false in - let update () : V.aloan_content = - assert (not !r); - r := true; - nlc - in - - let obj = - object - inherit [_] C.map_eval_ctx as super - - method! visit_aloan_content env lc = - match lc with - | V.AMutLoan (bid, av) -> - if bid = l then update () else super#visit_AMutLoan env bid av - | V.ASharedLoan (bids, v, av) -> - if V.BorrowId.Set.mem l bids then update () - else super#visit_ASharedLoan env bids v av - | V.AEndedMutLoan { given_back = _; child = _; given_back_meta = _ } - | V.AEndedSharedLoan (_, _) - | V.AIgnoredMutLoan (_, _) - | V.AEndedIgnoredMutLoan - { given_back = _; child = _; given_back_meta = _ } - | V.AIgnoredSharedLoan _ -> - super#visit_aloan_content env lc - - (** Note that once inside the abstractions, we don't control diving - (there are no use cases requiring finer control). *) - method! visit_abs env abs = - if ek.enter_abs then super#visit_abs env abs else abs - end - in - - let ctx = obj#visit_eval_ctx () ctx in - (* Check that we updated at least one loan *) - assert !r; - ctx - -(** Lookup a borrow content from a borrow id. *) -let lookup_borrow_opt (ek : exploration_kind) (l : V.BorrowId.id) - (ctx : C.eval_ctx) : g_borrow_content option = - let obj = - object - inherit [_] C.iter_eval_ctx as super - - method! visit_borrow_content env bc = - match bc with - | V.MutBorrow (bid, mv) -> - (* Check the borrow id and control the dive *) - if bid = l then raise (FoundGBorrowContent (Concrete bc)) - else if ek.enter_mut_borrows then super#visit_MutBorrow env bid mv - else () - | V.SharedBorrow (_, bid) -> - (* Check the borrow id *) - if bid = l then raise (FoundGBorrowContent (Concrete bc)) else () - | V.InactivatedMutBorrow (_, bid) -> - (* Check the borrow id *) - if bid = l then raise (FoundGBorrowContent (Concrete bc)) else () - - method! visit_loan_content env lc = - match lc with - | V.MutLoan bid -> - (* Nothing special to do *) super#visit_MutLoan env bid - | V.SharedLoan (bids, sv) -> - (* Control the dive *) - if ek.enter_shared_loans then super#visit_SharedLoan env bids sv - else () - - method! visit_aborrow_content env bc = - match bc with - | V.AMutBorrow (mv, bid, av) -> - if bid = l then raise (FoundGBorrowContent (Abstract bc)) - else super#visit_AMutBorrow env mv bid av - | V.ASharedBorrow bid -> - if bid = l then raise (FoundGBorrowContent (Abstract bc)) - else super#visit_ASharedBorrow env bid - | V.AIgnoredMutBorrow (_, _) - | V.AEndedMutBorrow _ - | V.AEndedIgnoredMutBorrow - { given_back_loans_proj = _; child = _; given_back_meta = _ } - | V.AEndedSharedBorrow -> - super#visit_aborrow_content env bc - | V.AProjSharedBorrow asb -> - if borrow_in_asb l asb then - raise (FoundGBorrowContent (Abstract bc)) - else () - - method! visit_abs env abs = - if ek.enter_abs then super#visit_abs env abs else () - end - in - (* We use exceptions *) - try - obj#visit_eval_ctx () ctx; - None - with FoundGBorrowContent lc -> Some lc - -(** Lookup a borrow content from a borrow id. - - Raise an exception if no loan was found -*) -let lookup_borrow (ek : exploration_kind) (l : V.BorrowId.id) (ctx : C.eval_ctx) - : g_borrow_content = - match lookup_borrow_opt ek l ctx with - | None -> failwith "Unreachable" - | Some lc -> lc - -(** Update a borrow content. - - The borrow is referred to by a borrow id. - - This is a helper function: it might break invariants. - *) -let update_borrow (ek : exploration_kind) (l : V.BorrowId.id) - (nbc : V.borrow_content) (ctx : C.eval_ctx) : C.eval_ctx = - (* We use a reference to check that we update exactly one borrow: when updating - * inside values, we check we don't update more than one borrow. Then, upon - * returning we check that we updated at least once. *) - let r = ref false in - let update () : V.borrow_content = - assert (not !r); - r := true; - nbc - in - - let obj = - object - inherit [_] C.map_eval_ctx as super - - method! visit_borrow_content env bc = - match bc with - | V.MutBorrow (bid, mv) -> - (* Check the id and control dive *) - if bid = l then update () - else if ek.enter_mut_borrows then super#visit_MutBorrow env bid mv - else V.MutBorrow (bid, mv) - | V.SharedBorrow (mv, bid) -> - (* Check the id *) - if bid = l then update () else super#visit_SharedBorrow env mv bid - | V.InactivatedMutBorrow (mv, bid) -> - (* Check the id *) - if bid = l then update () - else super#visit_InactivatedMutBorrow env mv bid - - method! visit_loan_content env lc = - match lc with - | V.SharedLoan (bids, sv) -> - (* Control the dive *) - if ek.enter_shared_loans then super#visit_SharedLoan env bids sv - else V.SharedLoan (bids, sv) - | V.MutLoan bid -> - (* Nothing specific to do *) - super#visit_MutLoan env bid - - method! visit_abs env abs = - if ek.enter_abs then super#visit_abs env abs else abs - end - in - - let ctx = obj#visit_eval_ctx () ctx in - (* Check that we updated at least one borrow *) - assert !r; - ctx - -(** Update an abstraction borrow content. - - The borrow is referred to by a borrow id. - - This is a helper function: it might break invariants. - *) -let update_aborrow (ek : exploration_kind) (l : V.BorrowId.id) (nv : V.avalue) - (ctx : C.eval_ctx) : C.eval_ctx = - (* We use a reference to check that we update exactly one borrow: when updating - * inside values, we check we don't update more than one borrow. Then, upon - * returning we check that we updated at least once. *) - let r = ref false in - let update () : V.avalue = - assert (not !r); - r := true; - nv - in - - let obj = - object - inherit [_] C.map_eval_ctx as super - - method! visit_ABorrow env bc = - match bc with - | V.AMutBorrow (mv, bid, av) -> - if bid = l then update () - else V.ABorrow (super#visit_AMutBorrow env mv bid av) - | V.ASharedBorrow bid -> - if bid = l then update () - else V.ABorrow (super#visit_ASharedBorrow env bid) - | V.AIgnoredMutBorrow _ | V.AEndedMutBorrow _ | V.AEndedSharedBorrow - | V.AEndedIgnoredMutBorrow _ -> - super#visit_ABorrow env bc - | V.AProjSharedBorrow asb -> - if borrow_in_asb l asb then update () - else V.ABorrow (super#visit_AProjSharedBorrow env asb) - - method! visit_abs env abs = - if ek.enter_abs then super#visit_abs env abs else abs - end - in - - let ctx = obj#visit_eval_ctx () ctx in - (* Check that we updated at least one borrow *) - assert !r; - ctx - -(** Auxiliary function: see its usage in [end_borrow_get_borrow_in_value] *) -let update_outer_borrows (outer : V.AbstractionId.id option * borrow_ids option) - (x : borrow_ids) : V.AbstractionId.id option * borrow_ids option = - let abs, opt = outer in - (abs, update_if_none opt x) - -(** Return the first loan we find in a value *) -let get_first_loan_in_value (v : V.typed_value) : V.loan_content option = - let obj = - object - inherit [_] V.iter_typed_value - method! visit_loan_content _ lc = raise (FoundLoanContent lc) - end - in - (* We use exceptions *) - try - obj#visit_typed_value () v; - None - with FoundLoanContent lc -> Some lc - -(** Return the first borrow we find in a value *) -let get_first_borrow_in_value (v : V.typed_value) : V.borrow_content option = - let obj = - object - inherit [_] V.iter_typed_value - method! visit_borrow_content _ bc = raise (FoundBorrowContent bc) - end - in - (* We use exceptions *) - try - obj#visit_typed_value () v; - None - with FoundBorrowContent bc -> Some bc - -(** Return the first loan or borrow content we find in a value (starting with - the outer ones). - - [with_borrows]: - - if true: return the first loan or borrow we find - - if false: return the first loan we find, do not dive into borrowed values - *) -let get_first_outer_loan_or_borrow_in_value (with_borrows : bool) - (v : V.typed_value) : loan_or_borrow_content option = - let obj = - object - inherit [_] V.iter_typed_value - - method! visit_borrow_content _ bc = - if with_borrows then raise (FoundBorrowContent bc) else () - - method! visit_loan_content _ lc = raise (FoundLoanContent lc) - end - in - (* We use exceptions *) - try - obj#visit_typed_value () v; - None - with - | FoundLoanContent lc -> Some (LoanContent lc) - | FoundBorrowContent bc -> Some (BorrowContent bc) - -type gproj_borrows = - | AProjBorrows of V.AbstractionId.id * V.symbolic_value - | ProjBorrows of V.symbolic_value - -let proj_borrows_intersects_proj_loans - (proj_borrows : T.RegionId.Set.t * V.symbolic_value * T.rty) - (proj_loans : T.RegionId.Set.t * V.symbolic_value) : bool = - let b_regions, b_sv, b_ty = proj_borrows in - let l_regions, l_sv = proj_loans in - if same_symbolic_id b_sv l_sv then - projections_intersect l_sv.V.sv_ty l_regions b_ty b_regions - else false - -(** Result of looking up aproj_borrows which intersect a given aproj_loans in - the context. - - Note that because we we force the expansion of primitively copyable values - before giving them to abstractions, we only have the following possibilities: - - no aproj_borrows, in which case the symbolic value was either dropped - or is in the context - - exactly one aproj_borrows over a non-shared value - - potentially several aproj_borrows over shared values - - The result contains the ids of the abstractions in which the projectors were - found, as well as the projection types used in those abstractions. -*) -type looked_up_aproj_borrows = - | NonSharedProj of V.AbstractionId.id * T.rty - | SharedProjs of (V.AbstractionId.id * T.rty) list - -(** Lookup the aproj_borrows (including aproj_shared_borrows) over a - symbolic value which intersect a given set of regions. - - [lookup_shared]: if [true] also explore projectors over shared values, - otherwise ignore. - - This is a helper function. -*) -let lookup_intersecting_aproj_borrows_opt (lookup_shared : bool) - (regions : T.RegionId.Set.t) (sv : V.symbolic_value) (ctx : C.eval_ctx) : - looked_up_aproj_borrows option = - let found : looked_up_aproj_borrows option ref = ref None in - let set_non_shared ((id, ty) : V.AbstractionId.id * T.rty) : unit = - match !found with - | None -> found := Some (NonSharedProj (id, ty)) - | Some _ -> failwith "Unreachable" - in - let add_shared (x : V.AbstractionId.id * T.rty) : unit = - match !found with - | None -> found := Some (SharedProjs [ x ]) - | Some (SharedProjs pl) -> found := Some (SharedProjs (x :: pl)) - | Some (NonSharedProj _) -> failwith "Unreachable" - in - let check_add_proj_borrows (is_shared : bool) abs sv' proj_ty = - if - proj_borrows_intersects_proj_loans - (abs.V.regions, sv', proj_ty) - (regions, sv) - then - let x = (abs.abs_id, proj_ty) in - if is_shared then add_shared x else set_non_shared x - else () - in - let obj = - object - inherit [_] C.iter_eval_ctx as super - method! visit_abs _ abs = super#visit_abs (Some abs) abs - - method! visit_abstract_shared_borrows abs asb = - (* Sanity check *) - (match !found with - | Some (NonSharedProj _) -> failwith "Unreachable" - | _ -> ()); - (* Explore *) - if lookup_shared then - let abs = Option.get abs in - let check asb = - match asb with - | V.AsbBorrow _ -> () - | V.AsbProjReborrows (sv', proj_ty) -> - let is_shared = true in - check_add_proj_borrows is_shared abs sv' proj_ty - in - List.iter check asb - else () - - method! visit_aproj abs sproj = - (let abs = Option.get abs in - match sproj with - | AProjLoans _ | AEndedProjLoans _ | AEndedProjBorrows _ - | AIgnoredProjBorrows -> - () - | AProjBorrows (sv', proj_rty) -> - let is_shared = false in - check_add_proj_borrows is_shared abs sv' proj_rty); - super#visit_aproj abs sproj - end - in - (* Visit *) - obj#visit_eval_ctx None ctx; - (* Return *) - !found - -(** Lookup the aproj_borrows (not aproj_borrows_shared!) over a symbolic - value which intersects a given set of regions. - - Note that there should be **at most one** (one reason is that we force - the expansion of primitively copyable values before giving them to - abstractions). - - Returns the id of the owning abstraction, and the projection type used in - this abstraction. -*) -let lookup_intersecting_aproj_borrows_not_shared_opt - (regions : T.RegionId.Set.t) (sv : V.symbolic_value) (ctx : C.eval_ctx) : - (V.AbstractionId.id * T.rty) option = - let lookup_shared = false in - match lookup_intersecting_aproj_borrows_opt lookup_shared regions sv ctx with - | None -> None - | Some (NonSharedProj (abs_id, rty)) -> Some (abs_id, rty) - | _ -> failwith "Unexpected" - -(** Similar to {!lookup_intersecting_aproj_borrows_opt}, but updates the - values. - - This is a helper function: it might break invariants. - *) -let update_intersecting_aproj_borrows (can_update_shared : bool) - (update_shared : V.AbstractionId.id -> T.rty -> V.abstract_shared_borrows) - (update_non_shared : V.AbstractionId.id -> T.rty -> V.aproj) - (regions : T.RegionId.Set.t) (sv : V.symbolic_value) (ctx : C.eval_ctx) : - C.eval_ctx = - (* Small helpers for sanity checks *) - let shared = ref None in - let add_shared () = - match !shared with None -> shared := Some true | Some b -> assert b - in - let set_non_shared () = - match !shared with - | None -> shared := Some false - | Some _ -> failwith "Found unexpected intersecting proj_borrows" - in - let check_proj_borrows is_shared abs sv' proj_ty = - if - proj_borrows_intersects_proj_loans - (abs.V.regions, sv', proj_ty) - (regions, sv) - then ( - if is_shared then add_shared () else set_non_shared (); - true) - else false - in - (* The visitor *) - let obj = - object - inherit [_] C.map_eval_ctx as super - method! visit_abs _ abs = super#visit_abs (Some abs) abs - - method! visit_abstract_shared_borrows abs asb = - (* Sanity check *) - (match !shared with Some b -> assert b | _ -> ()); - (* Explore *) - if can_update_shared then - let abs = Option.get abs in - let update (asb : V.abstract_shared_borrow) : - V.abstract_shared_borrows = - match asb with - | V.AsbBorrow _ -> [ asb ] - | V.AsbProjReborrows (sv', proj_ty) -> - let is_shared = true in - if check_proj_borrows is_shared abs sv' proj_ty then - update_shared abs.abs_id proj_ty - else [ asb ] - in - List.concat (List.map update asb) - else asb - - method! visit_aproj abs sproj = - match sproj with - | AProjLoans _ | AEndedProjLoans _ | AEndedProjBorrows _ - | AIgnoredProjBorrows -> - super#visit_aproj abs sproj - | AProjBorrows (sv', proj_rty) -> - let abs = Option.get abs in - let is_shared = true in - if check_proj_borrows is_shared abs sv' proj_rty then - update_non_shared abs.abs_id proj_rty - else super#visit_aproj (Some abs) sproj - end - in - (* Apply *) - let ctx = obj#visit_eval_ctx None ctx in - (* Check that we updated the context at least once *) - assert (Option.is_some !shared); - (* Return *) - ctx - -(** Simply calls {!update_intersecting_aproj_borrows} to update a - proj_borrows over a non-shared value. - - We check that we update *at least* one proj_borrows. - - This is a helper function: it might break invariants. - *) -let update_intersecting_aproj_borrows_non_shared (regions : T.RegionId.Set.t) - (sv : V.symbolic_value) (nv : V.aproj) (ctx : C.eval_ctx) : C.eval_ctx = - (* Small helpers *) - let can_update_shared = false in - let update_shared _ _ = failwith "Unexpected" in - let updated = ref false in - let update_non_shared _ _ = - (* We can update more than one borrow! *) - updated := true; - nv - in - (* Update *) - let ctx = - update_intersecting_aproj_borrows can_update_shared update_shared - update_non_shared regions sv ctx - in - (* Check that we updated at least once *) - assert !updated; - (* Return *) - ctx - -(** Simply calls {!update_intersecting_aproj_borrows} to remove the - proj_borrows over shared values. - - This is a helper function: it might break invariants. - *) -let remove_intersecting_aproj_borrows_shared (regions : T.RegionId.Set.t) - (sv : V.symbolic_value) (ctx : C.eval_ctx) : C.eval_ctx = - (* Small helpers *) - let can_update_shared = true in - let update_shared _ _ = [] in - let update_non_shared _ _ = failwith "Unexpected" in - (* Update *) - update_intersecting_aproj_borrows can_update_shared update_shared - update_non_shared regions sv ctx - -(** Updates the proj_loans intersecting some projection. - - This is a helper function: it might break invariants. - - Note that we can update more than one projector of loans! Consider the - following example: - {[ - fn f<'a, 'b>(...) -> (&'a mut u32, &'b mut u32)); - fn g<'c>(&'c mut u32, &'c mut u32); - - let p = f(...); - g(move p); - - // Symbolic context after the call to g: - // abs'a {'a} { [s@0 <: (&'a mut u32, &'b mut u32)] } - // abs'b {'b} { [s@0 <: (&'a mut u32, &'b mut u32)] } - // - // abs'c {'c} { (s@0 <: (&'c mut u32, &'c mut u32)) } - ]} - - Note that for sanity, this function checks that we update *at least* one - projector of loans. - - [subst]: takes as parameters the abstraction in which we perform the - substitution and the list of given back values at the projector of - loans where we perform the substitution (see the fields in {!V.AProjLoans}). - Note that the symbolic value at this place is necessarily equal to [sv], - which is why we don't give it as parameters. - *) -let update_intersecting_aproj_loans (proj_regions : T.RegionId.Set.t) - (proj_ty : T.rty) (sv : V.symbolic_value) - (subst : V.abs -> (V.msymbolic_value * V.aproj) list -> V.aproj) - (ctx : C.eval_ctx) : C.eval_ctx = - (* Small helpers for sanity checks *) - let updated = ref false in - let update abs local_given_back : V.aproj = - (* Note that we can update more than once! *) - updated := true; - subst abs local_given_back - in - (* The visitor *) - let obj = - object - inherit [_] C.map_eval_ctx as super - method! visit_abs _ abs = super#visit_abs (Some abs) abs - - method! visit_aproj abs sproj = - match sproj with - | AProjBorrows _ | AEndedProjLoans _ | AEndedProjBorrows _ - | AIgnoredProjBorrows -> - super#visit_aproj abs sproj - | AProjLoans (sv', given_back) -> - let abs = Option.get abs in - if same_symbolic_id sv sv' then ( - assert (sv.sv_ty = sv'.sv_ty); - if - projections_intersect proj_ty proj_regions sv'.V.sv_ty - abs.regions - then update abs given_back - else super#visit_aproj (Some abs) sproj) - else super#visit_aproj (Some abs) sproj - end - in - (* Apply *) - let ctx = obj#visit_eval_ctx None ctx in - (* Check that we updated the context at least once *) - assert !updated; - (* Return *) - ctx - -(** Helper function: lookup an {!V.AProjLoans} by using an abstraction id and a - symbolic value. - - We return the information from the looked up projector of loans. See the - fields in {!V.AProjLoans} (we don't return the symbolic value, because it - is equal to [sv]). - - Sanity check: we check that there is exactly one projector which corresponds - to the couple (abstraction id, symbolic value). - *) -let lookup_aproj_loans (abs_id : V.AbstractionId.id) (sv : V.symbolic_value) - (ctx : C.eval_ctx) : (V.msymbolic_value * V.aproj) list = - (* Small helpers for sanity checks *) - let found = ref None in - let set_found x = - (* There is at most one projector which corresponds to the description *) - assert (Option.is_none !found); - found := Some x - in - (* The visitor *) - let obj = - object - inherit [_] C.iter_eval_ctx as super - - method! visit_abs _ abs = - if abs.abs_id = abs_id then super#visit_abs (Some abs) abs else () - - method! visit_aproj (abs : V.abs option) sproj = - (match sproj with - | AProjBorrows _ | AEndedProjLoans _ | AEndedProjBorrows _ - | AIgnoredProjBorrows -> - super#visit_aproj abs sproj - | AProjLoans (sv', given_back) -> - let abs = Option.get abs in - assert (abs.abs_id = abs_id); - if sv'.sv_id = sv.sv_id then ( - assert (sv' = sv); - set_found given_back) - else ()); - super#visit_aproj abs sproj - end - in - (* Apply *) - obj#visit_eval_ctx None ctx; - (* Return *) - Option.get !found - -(** Helper function: might break invariants. - - Update a projector over loans. The projector is identified by a symbolic - value and an abstraction id. - - Sanity check: we check that there is exactly one projector which corresponds - to the couple (abstraction id, symbolic value). - *) -let update_aproj_loans (abs_id : V.AbstractionId.id) (sv : V.symbolic_value) - (nproj : V.aproj) (ctx : C.eval_ctx) : C.eval_ctx = - (* Small helpers for sanity checks *) - let found = ref false in - let update () = - (* We update at most once *) - assert (not !found); - found := true; - nproj - in - (* The visitor *) - let obj = - object - inherit [_] C.map_eval_ctx as super - - method! visit_abs _ abs = - if abs.abs_id = abs_id then super#visit_abs (Some abs) abs else abs - - method! visit_aproj (abs : V.abs option) sproj = - match sproj with - | AProjBorrows _ | AEndedProjLoans _ | AEndedProjBorrows _ - | AIgnoredProjBorrows -> - super#visit_aproj abs sproj - | AProjLoans (sv', _) -> - let abs = Option.get abs in - assert (abs.abs_id = abs_id); - if sv'.sv_id = sv.sv_id then ( - assert (sv' = sv); - update ()) - else super#visit_aproj (Some abs) sproj - end - in - (* Apply *) - let ctx = obj#visit_eval_ctx None ctx in - (* Sanity check *) - assert !found; - (* Return *) - ctx - -(** Helper function: might break invariants. - - Update a projector over borrows. The projector is identified by a symbolic - value and an abstraction id. - - Sanity check: we check that there is exactly one projector which corresponds - to the couple (abstraction id, symbolic value). - - TODO: factorize with {!update_aproj_loans}? - *) -let update_aproj_borrows (abs_id : V.AbstractionId.id) (sv : V.symbolic_value) - (nproj : V.aproj) (ctx : C.eval_ctx) : C.eval_ctx = - (* Small helpers for sanity checks *) - let found = ref false in - let update () = - (* We update at most once *) - assert (not !found); - found := true; - nproj - in - (* The visitor *) - let obj = - object - inherit [_] C.map_eval_ctx as super - - method! visit_abs _ abs = - if abs.abs_id = abs_id then super#visit_abs (Some abs) abs else abs - - method! visit_aproj (abs : V.abs option) sproj = - match sproj with - | AProjLoans _ | AEndedProjLoans _ | AEndedProjBorrows _ - | AIgnoredProjBorrows -> - super#visit_aproj abs sproj - | AProjBorrows (sv', _proj_ty) -> - let abs = Option.get abs in - assert (abs.abs_id = abs_id); - if sv'.sv_id = sv.sv_id then ( - assert (sv' = sv); - update ()) - else super#visit_aproj (Some abs) sproj - end - in - (* Apply *) - let ctx = obj#visit_eval_ctx None ctx in - (* Sanity check *) - assert !found; - (* Return *) - ctx - -(** Helper function: might break invariants. - - Converts an {!V.AProjLoans} to an {!V.AEndedProjLoans}. The projector is identified - by a symbolic value and an abstraction id. - *) -let update_aproj_loans_to_ended (abs_id : V.AbstractionId.id) - (sv : V.symbolic_value) (ctx : C.eval_ctx) : C.eval_ctx = - (* Lookup the projector of loans *) - let given_back = lookup_aproj_loans abs_id sv ctx in - (* Create the new value for the projector *) - let nproj = V.AEndedProjLoans (sv, given_back) in - (* Insert it *) - let ctx = update_aproj_loans abs_id sv nproj ctx in - (* Return *) - ctx - -let no_aproj_over_symbolic_in_context (sv : V.symbolic_value) (ctx : C.eval_ctx) - : unit = - (* The visitor *) - let obj = - object - inherit [_] C.iter_eval_ctx as super - - method! visit_aproj env sproj = - (match sproj with - | AEndedProjLoans _ | AEndedProjBorrows _ | AIgnoredProjBorrows -> () - | AProjLoans (sv', _) | AProjBorrows (sv', _) -> - if sv'.sv_id = sv.sv_id then raise Found else ()); - super#visit_aproj env sproj - end - in - (* Apply *) - try obj#visit_eval_ctx () ctx - with Found -> failwith "update_aproj_loans_to_ended: failed" - -(** Helper function - - Return the loan (aloan, loan, proj_loans over a symbolic value) we find - in an abstraction, if there is. - - **Remark:** we don't take the *ignored* mut/shared loans into account. - *) -let get_first_non_ignored_aloan_in_abstraction (abs : V.abs) : - borrow_ids_or_symbolic_value option = - (* Explore to find a loan *) - let obj = - object - inherit [_] V.iter_abs as super - - method! visit_aloan_content env lc = - match lc with - | V.AMutLoan (bid, _) -> raise (FoundBorrowIds (Borrow bid)) - | V.ASharedLoan (bids, _, _) -> raise (FoundBorrowIds (Borrows bids)) - | V.AEndedMutLoan { given_back = _; child = _; given_back_meta = _ } - | V.AEndedSharedLoan (_, _) -> - super#visit_aloan_content env lc - | V.AIgnoredMutLoan (_, _) -> - (* Ignore *) - super#visit_aloan_content env lc - | V.AEndedIgnoredMutLoan - { given_back = _; child = _; given_back_meta = _ } - | V.AIgnoredSharedLoan _ -> - (* Ignore *) - super#visit_aloan_content env lc - - (** We may need to visit loan contents because of shared values *) - method! visit_loan_content _ lc = - match lc with - | V.MutLoan _ -> - (* The mut loan linked to the mutable borrow present in a shared - * value in an abstraction should be in an AProjBorrows *) - failwith "Unreachable" - | V.SharedLoan (bids, _) -> raise (FoundBorrowIds (Borrows bids)) - - method! visit_aproj env sproj = - (match sproj with - | V.AProjBorrows (_, _) - | V.AEndedProjLoans _ | V.AEndedProjBorrows _ | V.AIgnoredProjBorrows -> - () - | V.AProjLoans (sv, _) -> raise (ValuesUtils.FoundSymbolicValue sv)); - super#visit_aproj env sproj - end - in - try - (* Check if there are loans *) - obj#visit_abs () abs; - (* No loans *) - None - with - (* There are loans *) - | FoundBorrowIds bids -> Some (BorrowIds bids) - | ValuesUtils.FoundSymbolicValue sv -> - (* There are loan projections over symbolic values *) - Some (SymbolicValue sv) diff --git a/src/InterpreterExpansion.ml b/src/InterpreterExpansion.ml deleted file mode 100644 index 0ca34b43..00000000 --- a/src/InterpreterExpansion.ml +++ /dev/null @@ -1,733 +0,0 @@ -(* This module provides the functions which handle expansion of symbolic values. - * For now, this file doesn't handle expansion of ⊥ values because they need - * some path utilities for replacement. We might change that in the future (by - * using indices to identify the values for instance). *) - -module T = Types -module V = Values -module E = Expressions -module C = Contexts -module Subst = Substitute -module L = Logging -open TypesUtils -module Inv = Invariants -module S = SynthesizeSymbolic -module SA = SymbolicAst -open Cps -open ValuesUtils -open InterpreterUtils -open InterpreterProjectors -open InterpreterBorrows - -(** The local logger *) -let log = L.expansion_log - -(** Projector kind *) -type proj_kind = LoanProj | BorrowProj - -(** Auxiliary function. - Apply a symbolic expansion to avalues in a context, targetting a specific - kind of projectors. - - [proj_kind] controls whether we apply the expansion to projectors - on loans or projectors on borrows. - - When dealing with reference expansion, it is necessary to first apply the - expansion on loan projectors, then on borrow projectors. The reason is - that reducing the borrow projectors might require to perform some reborrows, - in which case we need to lookup the corresponding loans in the context. - - [allow_reborrows] controls whether we allow reborrows or not. It is useful - only if we target borrow projectors. - - Also, if this function is called on an expansion for *shared references*, - the proj borrows should already have been expanded. - - TODO: the way this function is used is a bit complex, especially because of - the above condition. Maybe we should have: - 1. a generic function to expand the loan projectors - 2. a function to expand the borrow projectors for non-borrows - 3. specialized functions for mut borrows and shared borrows - Note that 2. and 3. may have a little bit of duplicated code, but hopefully - it would make things clearer. -*) -let apply_symbolic_expansion_to_target_avalues (config : C.config) - (allow_reborrows : bool) (proj_kind : proj_kind) - (original_sv : V.symbolic_value) (expansion : V.symbolic_expansion) - (ctx : C.eval_ctx) : C.eval_ctx = - (* Symbolic values contained in the expansion might contain already ended regions *) - let check_symbolic_no_ended = false in - (* Prepare reborrows registration *) - let fresh_reborrow, apply_registered_reborrows = - prepare_reborrows config allow_reborrows - in - (* Visitor to apply the expansion *) - let obj = - object (self) - inherit [_] C.map_eval_ctx as super - - (** When visiting an abstraction, we remember the regions it owns to be - able to properly reduce projectors when expanding symbolic values *) - method! visit_abs current_abs abs = - assert (Option.is_none current_abs); - let current_abs = Some abs in - super#visit_abs current_abs abs - - (** We carefully updated {!visit_ASymbolic} so that {!visit_aproj} is called - only on child projections (i.e., projections which appear in {!AEndedProjLoans}). - The role of visit_aproj is then to check we don't have to expand symbolic - values in child projections, because it should never happen - *) - method! visit_aproj current_abs aproj = - (match aproj with - | AProjLoans (sv, _) | AProjBorrows (sv, _) -> - assert (not (same_symbolic_id sv original_sv)) - | AEndedProjLoans _ | AEndedProjBorrows _ | AIgnoredProjBorrows -> ()); - super#visit_aproj current_abs aproj - - method! visit_ASymbolic current_abs aproj = - let current_abs = Option.get current_abs in - let proj_regions = current_abs.regions in - let ancestors_regions = current_abs.ancestors_regions in - (* Explore in depth first - we won't update anything: we simply - * want to check we don't have to expand inner symbolic value *) - match (aproj, proj_kind) with - | V.AEndedProjBorrows _, _ -> V.ASymbolic aproj - | V.AEndedProjLoans _, _ -> - (* Explore the given back values to make sure we don't have to expand - * anything in there *) - V.ASymbolic (self#visit_aproj (Some current_abs) aproj) - | V.AProjLoans (sv, given_back), LoanProj -> - (* Check if this is the symbolic value we are looking for *) - if same_symbolic_id sv original_sv then ( - (* There mustn't be any given back values *) - assert (given_back = []); - (* Apply the projector *) - let projected_value = - apply_proj_loans_on_symbolic_expansion proj_regions expansion - original_sv.V.sv_ty - in - (* Replace *) - projected_value.V.value) - else - (* Not the searched symbolic value: nothing to do *) - super#visit_ASymbolic (Some current_abs) aproj - | V.AProjBorrows (sv, proj_ty), BorrowProj -> - (* Check if this is the symbolic value we are looking for *) - if same_symbolic_id sv original_sv then - (* Convert the symbolic expansion to a value on which we can - * apply a projector (if the expansion is a reference expansion, - * convert it to a borrow) *) - (* WARNING: we mustn't get there if the expansion is for a shared - * reference. *) - let expansion = - symbolic_expansion_non_shared_borrow_to_value original_sv - expansion - in - (* Apply the projector *) - let projected_value = - apply_proj_borrows check_symbolic_no_ended ctx fresh_reborrow - proj_regions ancestors_regions expansion proj_ty - in - (* Replace *) - projected_value.V.value - else - (* Not the searched symbolic value: nothing to do *) - super#visit_ASymbolic (Some current_abs) aproj - | V.AProjLoans _, BorrowProj - | V.AProjBorrows (_, _), LoanProj - | V.AIgnoredProjBorrows, _ -> - (* Nothing to do *) - V.ASymbolic aproj - end - in - (* Apply the expansion *) - let ctx = obj#visit_eval_ctx None ctx in - (* Apply the reborrows *) - apply_registered_reborrows ctx - -(** Auxiliary function. - Apply a symbolic expansion to avalues in a context. -*) -let apply_symbolic_expansion_to_avalues (config : C.config) - (allow_reborrows : bool) (original_sv : V.symbolic_value) - (expansion : V.symbolic_expansion) (ctx : C.eval_ctx) : C.eval_ctx = - let apply_expansion proj_kind ctx = - apply_symbolic_expansion_to_target_avalues config allow_reborrows proj_kind - original_sv expansion ctx - in - (* First target the loan projectors, then the borrow projectors *) - let ctx = apply_expansion LoanProj ctx in - let ctx = apply_expansion BorrowProj ctx in - ctx - -(** Auxiliary function. - - Simply replace the symbolic values (*not avalues*) in the context with - a given value. Will break invariants if not used properly. -*) -let replace_symbolic_values (at_most_once : bool) - (original_sv : V.symbolic_value) (nv : V.value) (ctx : C.eval_ctx) : - C.eval_ctx = - (* Count *) - let replaced = ref false in - let replace () = - if at_most_once then assert (not !replaced); - replaced := true; - nv - in - (* Visitor to apply the substitution *) - let obj = - object - inherit [_] C.map_eval_ctx as super - - method! visit_Symbolic env spc = - if same_symbolic_id spc original_sv then replace () - else super#visit_Symbolic env spc - end - in - (* Apply the substitution *) - let ctx = obj#visit_eval_ctx None ctx in - (* Return *) - ctx - -(** Apply a symbolic expansion to a context, by replacing the original - symbolic value with its expanded value. Is valid only if the expansion - is not a borrow (i.e., an adt...). - - This function does update the synthesis. -*) -let apply_symbolic_expansion_non_borrow (config : C.config) - (original_sv : V.symbolic_value) (expansion : V.symbolic_expansion) - (ctx : C.eval_ctx) : C.eval_ctx = - (* Apply the expansion to non-abstraction values *) - let nv = symbolic_expansion_non_borrow_to_value original_sv expansion in - let at_most_once = false in - let ctx = replace_symbolic_values at_most_once original_sv nv.V.value ctx in - (* Apply the expansion to abstraction values *) - let allow_reborrows = false in - apply_symbolic_expansion_to_avalues config allow_reborrows original_sv - expansion ctx - -(** Compute the expansion of an adt value. - - The function might return a list of values if the symbolic value to expand - is an enumeration. - - [expand_enumerations] controls the expansion of enumerations: if false, it - doesn't allow the expansion of enumerations *containing several variants*. - *) -let compute_expanded_symbolic_adt_value (expand_enumerations : bool) - (kind : V.sv_kind) (def_id : T.TypeDeclId.id) - (regions : T.RegionId.id T.region list) (types : T.rty list) - (ctx : C.eval_ctx) : V.symbolic_expansion list = - (* Lookup the definition and check if it is an enumeration with several - * variants *) - let def = C.ctx_lookup_type_decl ctx def_id in - assert (List.length regions = List.length def.T.region_params); - (* Retrieve, for every variant, the list of its instantiated field types *) - let variants_fields_types = - Subst.type_decl_get_instantiated_variants_fields_rtypes def regions types - in - (* Check if there is strictly more than one variant *) - if List.length variants_fields_types > 1 && not expand_enumerations then - raise (Failure "Not allowed to expand enumerations with several variants"); - (* Initialize the expanded value for a given variant *) - let initialize - ((variant_id, field_types) : T.VariantId.id option * T.rty list) : - V.symbolic_expansion = - let field_values = - List.map (fun (ty : T.rty) -> mk_fresh_symbolic_value kind ty) field_types - in - let see = V.SeAdt (variant_id, field_values) in - see - in - (* Initialize all the expanded values of all the variants *) - List.map initialize variants_fields_types - -(** Compute the expansion of an Option value. - *) -let compute_expanded_symbolic_option_value (expand_enumerations : bool) - (kind : V.sv_kind) (ty : T.rty) : V.symbolic_expansion list = - assert expand_enumerations; - let some_se = - V.SeAdt (Some T.option_some_id, [ mk_fresh_symbolic_value kind ty ]) - in - let none_se = V.SeAdt (Some T.option_none_id, []) in - [ none_se; some_se ] - -let compute_expanded_symbolic_tuple_value (kind : V.sv_kind) - (field_types : T.rty list) : V.symbolic_expansion = - (* Generate the field values *) - let field_values = - List.map (fun sv_ty -> mk_fresh_symbolic_value kind sv_ty) field_types - in - let variant_id = None in - let see = V.SeAdt (variant_id, field_values) in - see - -let compute_expanded_symbolic_box_value (kind : V.sv_kind) (boxed_ty : T.rty) : - V.symbolic_expansion = - (* Introduce a fresh symbolic value *) - let boxed_value = mk_fresh_symbolic_value kind boxed_ty in - let see = V.SeAdt (None, [ boxed_value ]) in - see - -let expand_symbolic_value_shared_borrow (config : C.config) - (original_sv : V.symbolic_value) (original_sv_place : SA.mplace option) - (ref_ty : T.rty) : cm_fun = - fun cf ctx -> - (* First, replace the projectors on borrows. - * The important point is that the symbolic value to expand may appear - * several times, if it has been copied. In this case, we need to introduce - * one fresh borrow id per instance. - *) - let borrows = ref V.BorrowId.Set.empty in - let fresh_borrow () = - let bid' = C.fresh_borrow_id () in - borrows := V.BorrowId.Set.add bid' !borrows; - bid' - in - (* Small utility used on shared borrows in abstractions (regular borrow - * projector and asb). - * Returns [Some] if the symbolic value has been expanded to an asb list, - * [None] otherwise *) - let reborrow_ashared proj_regions (sv : V.symbolic_value) (proj_ty : T.rty) : - V.abstract_shared_borrows option = - if same_symbolic_id sv original_sv then - match proj_ty with - | T.Ref (r, ref_ty, T.Shared) -> - (* Projector over the shared value *) - let shared_asb = V.AsbProjReborrows (sv, ref_ty) in - (* Check if the region is in the set of projected regions *) - if region_in_set r proj_regions then - (* In the set: we need to reborrow *) - let bid = fresh_borrow () in - Some [ V.AsbBorrow bid; shared_asb ] - else (* Not in the set: ignore *) - Some [ shared_asb ] - | _ -> raise (Failure "Unexpected") - else None - in - (* The fresh symbolic value for the shared value *) - let shared_sv = mk_fresh_symbolic_value original_sv.sv_kind ref_ty in - (* Visitor to replace the projectors on borrows *) - let obj = - object (self) - inherit [_] C.map_eval_ctx as super - - method! visit_Symbolic env sv = - if same_symbolic_id sv original_sv then - let bid = fresh_borrow () in - V.Borrow - (V.SharedBorrow (mk_typed_value_from_symbolic_value shared_sv, bid)) - else super#visit_Symbolic env sv - - method! visit_Abs proj_regions abs = - assert (Option.is_none proj_regions); - let proj_regions = Some abs.V.regions in - super#visit_Abs proj_regions abs - - method! visit_AProjSharedBorrow proj_regions asb = - let expand_asb (asb : V.abstract_shared_borrow) : - V.abstract_shared_borrows = - match asb with - | V.AsbBorrow _ -> [ asb ] - | V.AsbProjReborrows (sv, proj_ty) -> ( - match reborrow_ashared (Option.get proj_regions) sv proj_ty with - | None -> [ asb ] - | Some asb -> asb) - in - let asb = List.concat (List.map expand_asb asb) in - V.AProjSharedBorrow asb - - (** We carefully updated {!visit_ASymbolic} so that {!visit_aproj} is called - only on child projections (i.e., projections which appear in {!AEndedProjLoans}). - The role of visit_aproj is then to check we don't have to expand symbolic - values in child projections, because it should never happen - *) - method! visit_aproj proj_regions aproj = - (match aproj with - | AProjLoans (sv, _) | AProjBorrows (sv, _) -> - assert (not (same_symbolic_id sv original_sv)) - | AEndedProjLoans _ | AEndedProjBorrows _ | AIgnoredProjBorrows -> ()); - super#visit_aproj proj_regions aproj - - method! visit_ASymbolic proj_regions aproj = - match aproj with - | AEndedProjBorrows _ | AIgnoredProjBorrows -> - (* We ignore borrows *) V.ASymbolic aproj - | AProjLoans _ -> - (* Loans are handled later *) - V.ASymbolic aproj - | AProjBorrows (sv, proj_ty) -> ( - (* Check if we need to reborrow *) - match reborrow_ashared (Option.get proj_regions) sv proj_ty with - | None -> super#visit_ASymbolic proj_regions aproj - | Some asb -> V.ABorrow (V.AProjSharedBorrow asb)) - | AEndedProjLoans _ -> - (* Sanity check: make sure there is nothing to expand inside the - * children projections *) - V.ASymbolic (self#visit_aproj proj_regions aproj) - end - in - (* Call the visitor *) - let ctx = obj#visit_eval_ctx None ctx in - (* Finally, replace the projectors on loans *) - let bids = !borrows in - assert (not (V.BorrowId.Set.is_empty bids)); - let see = V.SeSharedRef (bids, shared_sv) in - let allow_reborrows = true in - let ctx = - apply_symbolic_expansion_to_avalues config allow_reborrows original_sv see - ctx - in - (* Call the continuation *) - let expr = cf ctx in - (* Update the synthesized program *) - S.synthesize_symbolic_expansion_no_branching original_sv original_sv_place see - expr - -(** TODO: simplify and merge with the other expansion function *) -let expand_symbolic_value_borrow (config : C.config) - (original_sv : V.symbolic_value) (original_sv_place : SA.mplace option) - (region : T.RegionId.id T.region) (ref_ty : T.rty) (rkind : T.ref_kind) : - cm_fun = - fun cf ctx -> - (* Check that we are allowed to expand the reference *) - assert (not (region_in_set region ctx.ended_regions)); - (* Match on the reference kind *) - match rkind with - | T.Mut -> - (* Simple case: simply create a fresh symbolic value and a fresh - * borrow id *) - let sv = mk_fresh_symbolic_value original_sv.sv_kind ref_ty in - let bid = C.fresh_borrow_id () in - let see = V.SeMutRef (bid, sv) in - (* Expand the symbolic values - we simply perform a substitution (and - * check that we perform exactly one substitution) *) - let nv = symbolic_expansion_non_shared_borrow_to_value original_sv see in - let at_most_once = true in - let ctx = - replace_symbolic_values at_most_once original_sv nv.V.value ctx - in - (* Expand the symbolic avalues *) - let allow_reborrows = true in - let ctx = - apply_symbolic_expansion_to_avalues config allow_reborrows original_sv - see ctx - in - (* Apply the continuation *) - let expr = cf ctx in - (* Update the synthesized program *) - S.synthesize_symbolic_expansion_no_branching original_sv original_sv_place - see expr - | T.Shared -> - expand_symbolic_value_shared_borrow config original_sv original_sv_place - ref_ty cf ctx - -(** A small helper. - - Apply a branching symbolic expansion to a context and execute all the - branches. Note that the expansion is optional for every branch (this is - used for integer expansion: see [expand_symbolic_int]). - - [see_cf_l]: list of pairs (optional symbolic expansion, continuation) -*) -let apply_branching_symbolic_expansions_non_borrow (config : C.config) - (sv : V.symbolic_value) (sv_place : SA.mplace option) - (see_cf_l : (V.symbolic_expansion option * m_fun) list) : m_fun = - fun ctx -> - assert (see_cf_l <> []); - (* Apply the symbolic expansion in in the context and call the continuation *) - let resl = - List.map - (fun (see_opt, cf) -> - (* Expansion *) - let ctx = - match see_opt with - | None -> ctx - | Some see -> apply_symbolic_expansion_non_borrow config sv see ctx - in - (* Continuation *) - cf ctx) - see_cf_l - in - (* Collect the result: either we computed no subterm, or we computed all - * of them *) - let subterms = - match resl with - | Some _ :: _ -> Some (List.map Option.get resl) - | None :: _ -> - List.iter (fun res -> assert (res = None)) resl; - None - | _ -> raise (Failure "Unreachable") - in - (* Synthesize and return *) - let seel = List.map fst see_cf_l in - S.synthesize_symbolic_expansion sv sv_place seel subterms - -(** Expand a symbolic boolean *) -let expand_symbolic_bool (config : C.config) (sp : V.symbolic_value) - (sp_place : SA.mplace option) (cf_true : m_fun) (cf_false : m_fun) : m_fun = - fun ctx -> - (* Compute the expanded value *) - let original_sv = sp in - let original_sv_place = sp_place in - let rty = original_sv.V.sv_ty in - assert (rty = T.Bool); - (* Expand the symbolic value to true or false and continue execution *) - let see_true = V.SeConcrete (V.Bool true) in - let see_false = V.SeConcrete (V.Bool false) in - let seel = [ (Some see_true, cf_true); (Some see_false, cf_false) ] in - (* Apply the symbolic expansion (this also outputs the updated symbolic AST) *) - apply_branching_symbolic_expansions_non_borrow config original_sv - original_sv_place seel ctx - -(** Expand a symbolic value. - - [allow_branching]: if [true] we can branch (by expanding enumerations with - stricly more than one variant), otherwise we can't. - - TODO: rename [sp] to [sv] - *) -let expand_symbolic_value (config : C.config) (allow_branching : bool) - (sp : V.symbolic_value) (sp_place : SA.mplace option) : cm_fun = - fun cf ctx -> - (* Debug *) - log#ldebug (lazy ("expand_symbolic_value:" ^ symbolic_value_to_string ctx sp)); - (* Remember the initial context for printing purposes *) - let ctx0 = ctx in - (* Compute the expanded value - note that when doing so, we may introduce - * fresh symbolic values in the context (which thus gets updated) *) - let original_sv = sp in - let original_sv_place = sp_place in - let rty = original_sv.V.sv_ty in - let cc : cm_fun = - fun cf ctx -> - match rty with - (* TODO: I think it is possible to factorize a lot the below match *) - (* "Regular" ADTs *) - | T.Adt (T.AdtId def_id, regions, types) -> - (* Compute the expanded value *) - let seel = - compute_expanded_symbolic_adt_value allow_branching sp.sv_kind def_id - regions types ctx - in - (* Check for branching *) - assert (List.length seel <= 1 || allow_branching); - (* Apply *) - let seel = List.map (fun see -> (Some see, cf)) seel in - apply_branching_symbolic_expansions_non_borrow config original_sv - original_sv_place seel ctx - (* Options *) - | T.Adt (T.Assumed Option, regions, types) -> - (* Sanity check *) - assert (regions = []); - let ty = Collections.List.to_cons_nil types in - (* Compute the expanded value *) - let seel = - compute_expanded_symbolic_option_value allow_branching sp.sv_kind ty - in - - (* Check for branching *) - assert (List.length seel <= 1 || allow_branching); - (* Apply *) - let seel = List.map (fun see -> (Some see, cf)) seel in - apply_branching_symbolic_expansions_non_borrow config original_sv - original_sv_place seel ctx - (* Tuples *) - | T.Adt (T.Tuple, [], tys) -> - (* Generate the field values *) - let see = compute_expanded_symbolic_tuple_value sp.sv_kind tys in - (* Apply in the context *) - let ctx = - apply_symbolic_expansion_non_borrow config original_sv see ctx - in - (* Call the continuation *) - let expr = cf ctx in - (* Update the synthesized program *) - S.synthesize_symbolic_expansion_no_branching original_sv - original_sv_place see expr - (* Boxes *) - | T.Adt (T.Assumed T.Box, [], [ boxed_ty ]) -> - let see = compute_expanded_symbolic_box_value sp.sv_kind boxed_ty in - (* Apply in the context *) - let ctx = - apply_symbolic_expansion_non_borrow config original_sv see ctx - in - (* Call the continuation *) - let expr = cf ctx in - (* Update the synthesized program *) - S.synthesize_symbolic_expansion_no_branching original_sv - original_sv_place see expr - (* Borrows *) - | T.Ref (region, ref_ty, rkind) -> - expand_symbolic_value_borrow config original_sv original_sv_place region - ref_ty rkind cf ctx - (* Booleans *) - | T.Bool -> - assert allow_branching; - expand_symbolic_bool config sp sp_place cf cf ctx - | _ -> - raise - (Failure ("expand_symbolic_value: unexpected type: " ^ T.show_rty rty)) - in - (* Debug *) - let cc = - comp_unit cc (fun ctx -> - log#ldebug - (lazy - ("expand_symbolic_value: " - ^ symbolic_value_to_string ctx0 sp - ^ "\n\n- original context:\n" ^ eval_ctx_to_string ctx0 - ^ "\n\n- new context:\n" ^ eval_ctx_to_string ctx ^ "\n")); - (* Sanity check: the symbolic value has disappeared *) - assert (not (symbolic_value_id_in_ctx original_sv.V.sv_id ctx))) - in - (* Continue *) - cc cf ctx - -(** Symbolic integers are expanded upon evaluating a [switch], when the integer - is not an enumeration discriminant. - Note that a discriminant is never symbolic: we evaluate discriminant values - upon evaluating [eval_discriminant], which always generates a concrete value - (because if we call it on a symbolic enumeration, we expand the enumeration - *then* evaluate the discriminant). This is how we can spot "regular" switches - over integers. - - - When expanding a boolean upon evaluating an [if ... then ... else ...], - or an enumeration just before matching over it, we can simply expand the - boolean/enumeration (generating a list of contexts from which to execute) - then retry evaluating the [if ... then ... else ...] or the [match]: as - the scrutinee will then have a concrete value, the interpreter will switch - to the proper branch. - - However, when expanding a "regular" integer for a switch, there is always an - *otherwise* branch that we can take, for which the integer must remain symbolic - (because in this branch the scrutinee can take a range of values). We thus - can't simply expand then retry to evaluate the [switch], because then we - would loop... - - For this reason, we take the list of branches to execute as parameters, and - directly jump to those branches after the expansion, without reevaluating the - switch. The continuation is thus for the execution *after* the switch. -*) -let expand_symbolic_int (config : C.config) (sv : V.symbolic_value) - (sv_place : SA.mplace option) (int_type : T.integer_type) - (tgts : (V.scalar_value * m_fun) list) (otherwise : m_fun) : m_fun = - (* Sanity check *) - assert (sv.V.sv_ty = T.Integer int_type); - (* For all the branches of the switch, we expand the symbolic value - * to the value given by the branch and execute the branch statement. - * For the otherwise branch, we leave the symbolic value as it is - * (because this branch doesn't precisely define which should be the - * value of the scrutinee...) and simply execute the otherwise statement. - * - * First, generate the list of pairs: - * (optional expansion, statement to execute) - *) - let tgts = - List.map (fun (v, cf) -> (Some (V.SeConcrete (V.Scalar v)), cf)) tgts - in - let tgts = List.append tgts [ (None, otherwise) ] in - (* Then expand and evaluate - this generates the proper symbolic AST *) - apply_branching_symbolic_expansions_non_borrow config sv sv_place tgts - -(** See [expand_symbolic_value] *) -let expand_symbolic_value_no_branching (config : C.config) - (sv : V.symbolic_value) (sv_place : SA.mplace option) : cm_fun = - let allow_branching = false in - expand_symbolic_value config allow_branching sv sv_place - -(** Expand all the symbolic values which contain borrows. - Allows us to restrict ourselves to a simpler model for the projectors over - symbolic values. - - Fails if doing this requires to do a branching (because we need to expand - an enumeration with strictly more than one variant, a slice, etc.) or if - we need to expand a recursive type (because this leads to looping). - *) -let greedy_expand_symbolics_with_borrows (config : C.config) : cm_fun = - fun cf ctx -> - (* The visitor object, to look for symbolic values in the concrete environment *) - let obj = - object - inherit [_] C.iter_eval_ctx - - method! visit_Symbolic _ sv = - if ty_has_borrows ctx.type_context.type_infos sv.V.sv_ty then - raise (FoundSymbolicValue sv) - else () - - (** Don't enter abstractions *) - method! visit_abs _ _ = () - end - in - - let rec expand : cm_fun = - fun cf ctx -> - try - obj#visit_eval_ctx () ctx; - (* Nothing to expand: continue *) - cf ctx - with FoundSymbolicValue sv -> - (* Expand and recheck the environment *) - log#ldebug - (lazy - ("greedy_expand_symbolics_with_borrows: about to expand: " - ^ symbolic_value_to_string ctx sv)); - let cc : cm_fun = - match sv.V.sv_ty with - | T.Adt (AdtId def_id, _, _) -> - (* {!expand_symbolic_value_no_branching} checks if there are branchings, - * but we prefer to also check it here - this leads to cleaner messages - * and debugging *) - let def = C.ctx_lookup_type_decl ctx def_id in - (match def.kind with - | T.Struct _ | T.Enum ([] | [ _ ]) -> () - | T.Enum (_ :: _) -> - raise - (Failure - ("Attempted to greedily expand a symbolic enumeration \ - with > 1 variants (option \ - [greedy_expand_symbolics_with_borrows] of [config]): " - ^ Print.name_to_string def.name)) - | T.Opaque -> - raise (Failure "Attempted to greedily expand an opaque type")); - (* Also, we need to check if the definition is recursive *) - if C.ctx_type_decl_is_rec ctx def_id then - raise - (Failure - ("Attempted to greedily expand a recursive definition \ - (option [greedy_expand_symbolics_with_borrows] of \ - [config]): " - ^ Print.name_to_string def.name)) - else expand_symbolic_value_no_branching config sv None - | T.Adt ((Tuple | Assumed Box), _, _) | T.Ref (_, _, _) -> - (* Ok *) - expand_symbolic_value_no_branching config sv None - | T.Adt (Assumed (Vec | Option), _, _) -> - (* We can't expand those *) - raise (Failure "Attempted to greedily expand a Vec or an Option ") - | T.Array _ -> raise Errors.Unimplemented - | T.Slice _ -> raise (Failure "Can't expand symbolic slices") - | T.TypeVar _ | Bool | Char | Never | Integer _ | Str -> - raise (Failure "Unreachable") - in - (* Compose and continue *) - comp cc expand cf ctx - in - (* Apply *) - expand cf ctx - -(** If this mode is activated through the [config], greedily expand the symbolic - values which need to be expanded. See [config] for more information. - *) -let greedy_expand_symbolic_values (config : C.config) : cm_fun = - fun cf ctx -> - if config.greedy_expand_symbolics_with_borrows then ( - log#ldebug (lazy "greedy_expand_symbolic_values"); - greedy_expand_symbolics_with_borrows config cf ctx) - else cf ctx diff --git a/src/InterpreterExpressions.ml b/src/InterpreterExpressions.ml deleted file mode 100644 index 62d9b80b..00000000 --- a/src/InterpreterExpressions.ml +++ /dev/null @@ -1,720 +0,0 @@ -module T = Types -module V = Values -module LA = LlbcAst -open Scalars -module E = Expressions -open Errors -module C = Contexts -module Subst = Substitute -module L = Logging -module PV = Print.Values -open TypesUtils -open ValuesUtils -module Inv = Invariants -module S = SynthesizeSymbolic -open Cps -open InterpreterUtils -open InterpreterExpansion -open InterpreterPaths - -(** The local logger *) -let log = L.expressions_log - -(** As long as there are symbolic values at a given place (potentially in subvalues) - which contain borrows and are primitively copyable, expand them. - - We use this function before copying values. - - Note that the place should have been prepared so that there are no remaining - loans. -*) -let expand_primitively_copyable_at_place (config : C.config) - (access : access_kind) (p : E.place) : cm_fun = - fun cf ctx -> - (* Small helper *) - let rec expand : cm_fun = - fun cf ctx -> - let v = read_place_unwrap config access p ctx in - match - find_first_primitively_copyable_sv_with_borrows - ctx.type_context.type_infos v - with - | None -> cf ctx - | Some sv -> - let cc = - expand_symbolic_value_no_branching config sv - (Some (S.mk_mplace p ctx)) - in - comp cc expand cf ctx - in - (* Apply *) - expand cf ctx - -(** Read a place (CPS-style function). - - We also check that the value *doesn't contain bottoms or inactivated - borrows. - *) -let read_place (config : C.config) (access : access_kind) (p : E.place) - (cf : V.typed_value -> m_fun) : m_fun = - fun ctx -> - let v = read_place_unwrap config access p ctx in - (* Check that there are no bottoms in the value *) - assert (not (bottom_in_value ctx.ended_regions v)); - (* Check that there are no inactivated borrows in the value *) - assert (not (inactivated_in_value v)); - (* Call the continuation *) - cf v ctx - -(** Small utility. - - Prepare the access to a place in a right-value (typically an operand) by - reorganizing the environment. - - We reorganize the environment so that: - - we can access the place (we prepare *along* the path) - - the value at the place itself doesn't contain loans (the [access_kind] - controls whether we only end mutable loans, or also shared loans). - - We also check, after the reorganization, that the value at the place - *doesn't contain any bottom nor inactivated borrows*. - - [expand_prim_copy]: if true, expand the symbolic values which are primitively - copyable and contain borrows. - *) -let access_rplace_reorganize_and_read (config : C.config) - (expand_prim_copy : bool) (access : access_kind) (p : E.place) - (cf : V.typed_value -> m_fun) : m_fun = - fun ctx -> - (* Make sure we can evaluate the path *) - let cc = update_ctx_along_read_place config access p in - (* End the proper loans at the place itself *) - let cc = comp cc (end_loans_at_place config access p) in - (* Expand the copyable values which contain borrows (which are necessarily shared - * borrows) *) - let cc = - if expand_prim_copy then - comp cc (expand_primitively_copyable_at_place config access p) - else cc - in - (* Read the place - note that this checks that the value doesn't contain bottoms *) - let read_place = read_place config access p in - (* Compose *) - comp cc read_place cf ctx - -let access_rplace_reorganize (config : C.config) (expand_prim_copy : bool) - (access : access_kind) (p : E.place) : cm_fun = - fun cf ctx -> - access_rplace_reorganize_and_read config expand_prim_copy access p - (fun _v -> cf) - ctx - -(** Convert an operand constant operand value to a typed value *) -let constant_to_typed_value (ty : T.ety) (cv : V.constant_value) : V.typed_value - = - (* Check the type while converting - we actually need some information - * contained in the type *) - log#ldebug - (lazy - ("constant_to_typed_value:" ^ "\n- cv: " ^ PV.constant_value_to_string cv)); - match (ty, cv) with - (* Scalar, boolean... *) - | T.Bool, Bool v -> { V.value = V.Concrete (Bool v); ty } - | T.Char, Char v -> { V.value = V.Concrete (Char v); ty } - | T.Str, String v -> { V.value = V.Concrete (String v); ty } - | T.Integer int_ty, V.Scalar v -> - (* Check the type and the ranges *) - assert (int_ty = v.int_ty); - assert (check_scalar_value_in_range v); - { V.value = V.Concrete (V.Scalar v); ty } - (* Remaining cases (invalid) *) - | _, _ -> failwith "Improperly typed constant value" - -(** Reorganize the environment in preparation for the evaluation of an operand. - - Evaluating an operand requires reorganizing the environment to get access - to a given place (by ending borrows, expanding symbolic values...) then - applying the operand operation (move, copy, etc.). - - Sometimes, we want to decouple the two operations. - Consider the following example: - {[ - context = { - x -> shared_borrow l0 - y -> shared_loan {l0} v - } - - dest <- f(move x, move y); - ... - ]} - Because of the way [end_borrow] is implemented, when giving back the borrow - [l0] upon evaluating [move y], we won't notice that [shared_borrow l0] has - disappeared from the environment (it has been moved and not assigned yet, - and so is hanging in "thin air"). - - By first "preparing" the operands evaluation, we make sure no such thing - happens. To be more precise, we make sure all the updates to borrows triggered - by access *and* move operations have already been applied. - - Rk.: in the formalization, we always have an explicit "reorganization" step - in the rule premises, before the actual operand evaluation. - - Rk.: doing this is actually not completely necessary because when - generating MIR, rustc introduces intermediate assignments for all the function - parameters. Still, it is better for soundness purposes, and corresponds to - what we do in the formalization (because we don't enforce constraints - in the formalization). - *) -let prepare_eval_operand_reorganize (config : C.config) (op : E.operand) : - cm_fun = - fun cf ctx -> - let prepare : cm_fun = - fun cf ctx -> - match op with - | Expressions.Constant (ty, cv) -> - (* No need to reorganize the context *) - constant_to_typed_value ty cv |> ignore; - cf ctx - | Expressions.Copy p -> - (* Access the value *) - let access = Read in - (* Expand the symbolic values, if necessary *) - let expand_prim_copy = true in - access_rplace_reorganize config expand_prim_copy access p cf ctx - | Expressions.Move p -> - (* Access the value *) - let access = Move in - let expand_prim_copy = false in - access_rplace_reorganize config expand_prim_copy access p cf ctx - in - (* Apply *) - prepare cf ctx - -(** Evaluate an operand, without reorganizing the context before *) -let eval_operand_no_reorganize (config : C.config) (op : E.operand) - (cf : V.typed_value -> m_fun) : m_fun = - fun ctx -> - (* Debug *) - log#ldebug - (lazy - ("eval_operand_no_reorganize: op: " ^ operand_to_string ctx op - ^ "\n- ctx:\n" ^ eval_ctx_to_string ctx ^ "\n")); - (* Evaluate *) - match op with - | Expressions.Constant (ty, cv) -> cf (constant_to_typed_value ty cv) ctx - | Expressions.Copy p -> - (* Access the value *) - let access = Read in - let cc = read_place config access p in - (* Copy the value *) - let copy cf v : m_fun = - fun ctx -> - (* Sanity checks *) - assert (not (bottom_in_value ctx.ended_regions v)); - assert ( - Option.is_none - (find_first_primitively_copyable_sv_with_borrows - ctx.type_context.type_infos v)); - (* Actually perform the copy *) - let allow_adt_copy = false in - let ctx, v = copy_value allow_adt_copy config ctx v in - (* Continue *) - cf v ctx - in - (* Compose and apply *) - comp cc copy cf ctx - | Expressions.Move p -> - (* Access the value *) - let access = Move in - let cc = read_place config access p in - (* Move the value *) - let move cf v : m_fun = - fun ctx -> - (* Check that there are no bottoms in the value we are about to move *) - assert (not (bottom_in_value ctx.ended_regions v)); - let bottom : V.typed_value = { V.value = Bottom; ty = v.ty } in - match write_place config access p bottom ctx with - | Error _ -> failwith "Unreachable" - | Ok ctx -> cf v ctx - in - (* Compose and apply *) - comp cc move cf ctx - -(** Evaluate an operand. - - Reorganize the context, then evaluate the operand. - - **Warning**: this function shouldn't be used to evaluate a list of - operands (for a function call, for instance): we must do *one* reorganization - of the environment, before evaluating all the operands at once. - Use [eval_operands] instead. - *) -let eval_operand (config : C.config) (op : E.operand) - (cf : V.typed_value -> m_fun) : m_fun = - fun ctx -> - (* Debug *) - log#ldebug - (lazy - ("eval_operand: op: " ^ operand_to_string ctx op ^ "\n- ctx:\n" - ^ eval_ctx_to_string ctx ^ "\n")); - (* We reorganize the context, then evaluate the operand *) - comp - (prepare_eval_operand_reorganize config op) - (eval_operand_no_reorganize config op) - cf ctx - -(** Small utility. - - See [prepare_eval_operand_reorganize]. - *) -let prepare_eval_operands_reorganize (config : C.config) (ops : E.operand list) - : cm_fun = - fold_left_apply_continuation (prepare_eval_operand_reorganize config) ops - -(** Evaluate several operands. *) -let eval_operands (config : C.config) (ops : E.operand list) - (cf : V.typed_value list -> m_fun) : m_fun = - fun ctx -> - (* Prepare the operands *) - let prepare = prepare_eval_operands_reorganize config ops in - (* Evaluate the operands *) - let eval = - fold_left_list_apply_continuation (eval_operand_no_reorganize config) ops - in - (* Compose and apply *) - comp prepare eval cf ctx - -let eval_two_operands (config : C.config) (op1 : E.operand) (op2 : E.operand) - (cf : V.typed_value * V.typed_value -> m_fun) : m_fun = - let eval_op = eval_operands config [ op1; op2 ] in - let use_res cf res = - match res with [ v1; v2 ] -> cf (v1, v2) | _ -> failwith "Unreachable" - in - comp eval_op use_res cf - -let eval_unary_op_concrete (config : C.config) (unop : E.unop) (op : E.operand) - (cf : (V.typed_value, eval_error) result -> m_fun) : m_fun = - (* Evaluate the operand *) - let eval_op = eval_operand config op in - (* Apply the unop *) - let apply cf (v : V.typed_value) : m_fun = - match (unop, v.V.value) with - | E.Not, V.Concrete (Bool b) -> - cf (Ok { v with V.value = V.Concrete (Bool (not b)) }) - | E.Neg, V.Concrete (V.Scalar sv) -> ( - let i = Z.neg sv.V.value in - match mk_scalar sv.int_ty i with - | Error _ -> cf (Error EPanic) - | Ok sv -> cf (Ok { v with V.value = V.Concrete (V.Scalar sv) })) - | E.Cast (src_ty, tgt_ty), V.Concrete (V.Scalar sv) -> ( - assert (src_ty == sv.int_ty); - let i = sv.V.value in - match mk_scalar tgt_ty i with - | Error _ -> cf (Error EPanic) - | Ok sv -> - let ty = T.Integer tgt_ty in - let value = V.Concrete (V.Scalar sv) in - cf (Ok { V.ty; value })) - | _ -> raise (Failure "Invalid input for unop") - in - comp eval_op apply cf - -let eval_unary_op_symbolic (config : C.config) (unop : E.unop) (op : E.operand) - (cf : (V.typed_value, eval_error) result -> m_fun) : m_fun = - fun ctx -> - (* Evaluate the operand *) - let eval_op = eval_operand config op in - (* Generate a fresh symbolic value to store the result *) - let apply cf (v : V.typed_value) : m_fun = - fun ctx -> - let res_sv_id = C.fresh_symbolic_value_id () in - let res_sv_ty = - match (unop, v.V.ty) with - | E.Not, T.Bool -> T.Bool - | E.Neg, T.Integer int_ty -> T.Integer int_ty - | E.Cast (_, tgt_ty), _ -> T.Integer tgt_ty - | _ -> raise (Failure "Invalid input for unop") - in - let res_sv = - { V.sv_kind = V.FunCallRet; V.sv_id = res_sv_id; sv_ty = res_sv_ty } - in - (* Call the continuation *) - let expr = cf (Ok (mk_typed_value_from_symbolic_value res_sv)) ctx in - (* Synthesize the symbolic AST *) - S.synthesize_unary_op unop v - (S.mk_opt_place_from_op op ctx) - res_sv None expr - in - (* Compose and apply *) - comp eval_op apply cf ctx - -let eval_unary_op (config : C.config) (unop : E.unop) (op : E.operand) - (cf : (V.typed_value, eval_error) result -> m_fun) : m_fun = - match config.mode with - | C.ConcreteMode -> eval_unary_op_concrete config unop op cf - | C.SymbolicMode -> eval_unary_op_symbolic config unop op cf - -(** Small helper for [eval_binary_op_concrete]: computes the result of applying - the binop *after* the operands have been successfully evaluated - *) -let eval_binary_op_concrete_compute (binop : E.binop) (v1 : V.typed_value) - (v2 : V.typed_value) : (V.typed_value, eval_error) result = - (* Equality check binops (Eq, Ne) accept values from a wide variety of types. - * The remaining binops only operate on scalars. *) - if binop = Eq || binop = Ne then ( - (* Equality operations *) - assert (v1.ty = v2.ty); - (* Equality/inequality check is primitive only for a subset of types *) - assert (ty_is_primitively_copyable v1.ty); - let b = v1 = v2 in - Ok { V.value = V.Concrete (Bool b); ty = T.Bool }) - else - (* For the non-equality operations, the input values are necessarily scalars *) - match (v1.V.value, v2.V.value) with - | V.Concrete (V.Scalar sv1), V.Concrete (V.Scalar sv2) -> ( - (* There are binops which require the two operands to have the same - type, and binops for which it is not the case. - There are also binops which return booleans, and binops which - return integers. - *) - match binop with - | E.Lt | E.Le | E.Ge | E.Gt -> - (* The two operands must have the same type and the result is a boolean *) - assert (sv1.int_ty = sv2.int_ty); - let b = - match binop with - | E.Lt -> Z.lt sv1.V.value sv2.V.value - | E.Le -> Z.leq sv1.V.value sv2.V.value - | E.Ge -> Z.geq sv1.V.value sv2.V.value - | E.Gt -> Z.gt sv1.V.value sv2.V.value - | E.Div | E.Rem | E.Add | E.Sub | E.Mul | E.BitXor | E.BitAnd - | E.BitOr | E.Shl | E.Shr | E.Ne | E.Eq -> - raise (Failure "Unreachable") - in - Ok ({ V.value = V.Concrete (Bool b); ty = T.Bool } : V.typed_value) - | E.Div | E.Rem | E.Add | E.Sub | E.Mul | E.BitXor | E.BitAnd | E.BitOr - -> ( - (* The two operands must have the same type and the result is an integer *) - assert (sv1.int_ty = sv2.int_ty); - let res = - match binop with - | E.Div -> - if sv2.V.value = Z.zero then Error () - else mk_scalar sv1.int_ty (Z.div sv1.V.value sv2.V.value) - | E.Rem -> - (* See [https://github.com/ocaml/Zarith/blob/master/z.mli] *) - if sv2.V.value = Z.zero then Error () - else mk_scalar sv1.int_ty (Z.rem sv1.V.value sv2.V.value) - | E.Add -> mk_scalar sv1.int_ty (Z.add sv1.V.value sv2.V.value) - | E.Sub -> mk_scalar sv1.int_ty (Z.sub sv1.V.value sv2.V.value) - | E.Mul -> mk_scalar sv1.int_ty (Z.mul sv1.V.value sv2.V.value) - | E.BitXor -> raise Unimplemented - | E.BitAnd -> raise Unimplemented - | E.BitOr -> raise Unimplemented - | E.Lt | E.Le | E.Ge | E.Gt | E.Shl | E.Shr | E.Ne | E.Eq -> - raise (Failure "Unreachable") - in - match res with - | Error _ -> Error EPanic - | Ok sv -> - Ok - { - V.value = V.Concrete (V.Scalar sv); - ty = Integer sv1.int_ty; - }) - | E.Shl | E.Shr -> raise Unimplemented - | E.Ne | E.Eq -> raise (Failure "Unreachable")) - | _ -> raise (Failure "Invalid inputs for binop") - -let eval_binary_op_concrete (config : C.config) (binop : E.binop) - (op1 : E.operand) (op2 : E.operand) - (cf : (V.typed_value, eval_error) result -> m_fun) : m_fun = - (* Evaluate the operands *) - let eval_ops = eval_two_operands config op1 op2 in - (* Compute the result of the binop *) - let compute cf (res : V.typed_value * V.typed_value) = - let v1, v2 = res in - cf (eval_binary_op_concrete_compute binop v1 v2) - in - (* Compose and apply *) - comp eval_ops compute cf - -let eval_binary_op_symbolic (config : C.config) (binop : E.binop) - (op1 : E.operand) (op2 : E.operand) - (cf : (V.typed_value, eval_error) result -> m_fun) : m_fun = - fun ctx -> - (* Evaluate the operands *) - let eval_ops = eval_two_operands config op1 op2 in - (* Compute the result of applying the binop *) - let compute cf ((v1, v2) : V.typed_value * V.typed_value) : m_fun = - fun ctx -> - (* Generate a fresh symbolic value to store the result *) - let res_sv_id = C.fresh_symbolic_value_id () in - let res_sv_ty = - if binop = Eq || binop = Ne then ( - (* Equality operations *) - assert (v1.ty = v2.ty); - (* Equality/inequality check is primitive only for a subset of types *) - assert (ty_is_primitively_copyable v1.ty); - T.Bool) - else - (* Other operations: input types are integers *) - match (v1.V.ty, v2.V.ty) with - | T.Integer int_ty1, T.Integer int_ty2 -> ( - match binop with - | E.Lt | E.Le | E.Ge | E.Gt -> - assert (int_ty1 = int_ty2); - T.Bool - | E.Div | E.Rem | E.Add | E.Sub | E.Mul | E.BitXor | E.BitAnd - | E.BitOr -> - assert (int_ty1 = int_ty2); - T.Integer int_ty1 - | E.Shl | E.Shr -> raise Unimplemented - | E.Ne | E.Eq -> raise (Failure "Unreachable")) - | _ -> raise (Failure "Invalid inputs for binop") - in - let res_sv = - { V.sv_kind = V.FunCallRet; V.sv_id = res_sv_id; sv_ty = res_sv_ty } - in - (* Call the continuattion *) - let v = mk_typed_value_from_symbolic_value res_sv in - let expr = cf (Ok v) ctx in - (* Synthesize the symbolic AST *) - let p1 = S.mk_opt_place_from_op op1 ctx in - let p2 = S.mk_opt_place_from_op op2 ctx in - S.synthesize_binary_op binop v1 p1 v2 p2 res_sv None expr - in - (* Compose and apply *) - comp eval_ops compute cf ctx - -let eval_binary_op (config : C.config) (binop : E.binop) (op1 : E.operand) - (op2 : E.operand) (cf : (V.typed_value, eval_error) result -> m_fun) : m_fun - = - match config.mode with - | C.ConcreteMode -> eval_binary_op_concrete config binop op1 op2 cf - | C.SymbolicMode -> eval_binary_op_symbolic config binop op1 op2 cf - -(** Evaluate the discriminant of a concrete (i.e., non symbolic) ADT value *) -let eval_rvalue_discriminant_concrete (config : C.config) (p : E.place) - (cf : V.typed_value -> m_fun) : m_fun = - (* Note that discriminant values have type [isize] *) - (* Access the value *) - let access = Read in - let expand_prim_copy = false in - let prepare = - access_rplace_reorganize_and_read config expand_prim_copy access p - in - (* Read the value *) - let read (cf : V.typed_value -> m_fun) (v : V.typed_value) : m_fun = - (* The value may be shared: we need to ignore the shared loans *) - let v = value_strip_shared_loans v in - match v.V.value with - | Adt av -> ( - match av.variant_id with - | None -> - raise - (Failure - "Invalid input for `discriminant`: structure instead of enum") - | Some variant_id -> ( - let id = Z.of_int (T.VariantId.to_int variant_id) in - match mk_scalar Isize id with - | Error _ -> raise (Failure "Disciminant id out of range") - (* Should really never happen *) - | Ok sv -> - cf { V.value = V.Concrete (V.Scalar sv); ty = Integer Isize })) - | _ -> - raise - (Failure ("Invalid input for `discriminant`: " ^ V.show_typed_value v)) - in - (* Compose and apply *) - comp prepare read cf - -(** Evaluate the discriminant of an ADT value. - - Might lead to branching, if the value is symbolic. - *) -let eval_rvalue_discriminant (config : C.config) (p : E.place) - (cf : V.typed_value -> m_fun) : m_fun = - fun ctx -> - log#ldebug (lazy "eval_rvalue_discriminant"); - (* Note that discriminant values have type [isize] *) - (* Access the value *) - let access = Read in - let expand_prim_copy = false in - let prepare = - access_rplace_reorganize_and_read config expand_prim_copy access p - in - (* Read the value *) - let read (cf : V.typed_value -> m_fun) (v : V.typed_value) : m_fun = - fun ctx -> - (* The value may be shared: we need to ignore the shared loans *) - let v = value_strip_shared_loans v in - match v.V.value with - | Adt _ -> eval_rvalue_discriminant_concrete config p cf ctx - | Symbolic sv -> - (* Expand the symbolic value - may lead to branching *) - let allow_branching = true in - let cc = - expand_symbolic_value config allow_branching sv - (Some (S.mk_mplace p ctx)) - in - (* This time the value is concrete: reevaluate *) - comp cc (eval_rvalue_discriminant_concrete config p) cf ctx - | _ -> - raise - (Failure ("Invalid input for `discriminant`: " ^ V.show_typed_value v)) - in - (* Compose and apply *) - comp prepare read cf ctx - -let eval_rvalue_ref (config : C.config) (p : E.place) (bkind : E.borrow_kind) - (cf : V.typed_value -> m_fun) : m_fun = - fun ctx -> - match bkind with - | E.Shared | E.TwoPhaseMut -> - (* Access the value *) - let access = if bkind = E.Shared then Read else Write in - let expand_prim_copy = false in - let prepare = - access_rplace_reorganize_and_read config expand_prim_copy access p - in - (* Evaluate the borrowing operation *) - let eval (cf : V.typed_value -> m_fun) (v : V.typed_value) : m_fun = - fun ctx -> - (* Generate the fresh borrow id *) - let bid = C.fresh_borrow_id () in - (* Compute the loan value, with which to replace the value at place p *) - let nv, shared_mvalue = - match v.V.value with - | V.Loan (V.SharedLoan (bids, sv)) -> - (* Shared loan: insert the new borrow id *) - let bids1 = V.BorrowId.Set.add bid bids in - ({ v with V.value = V.Loan (V.SharedLoan (bids1, sv)) }, sv) - | _ -> - (* Not a shared loan: add a wrapper *) - let v' = - V.Loan (V.SharedLoan (V.BorrowId.Set.singleton bid, v)) - in - ({ v with V.value = v' }, v) - in - (* Update the borrowed value in the context *) - let ctx = write_place_unwrap config access p nv ctx in - (* Compute the rvalue - simply a shared borrow with a the fresh id. - * Note that the reference is *mutable* if we do a two-phase borrow *) - let rv_ty = - T.Ref (T.Erased, v.ty, if bkind = E.Shared then Shared else Mut) - in - let bc = - if bkind = E.Shared then V.SharedBorrow (shared_mvalue, bid) - else V.InactivatedMutBorrow (shared_mvalue, bid) - in - let rv : V.typed_value = { V.value = V.Borrow bc; ty = rv_ty } in - (* Continue *) - cf rv ctx - in - (* Compose and apply *) - comp prepare eval cf ctx - | E.Mut -> - (* Access the value *) - let access = Write in - let expand_prim_copy = false in - let prepare = - access_rplace_reorganize_and_read config expand_prim_copy access p - in - (* Evaluate the borrowing operation *) - let eval (cf : V.typed_value -> m_fun) (v : V.typed_value) : m_fun = - fun ctx -> - (* Compute the rvalue - wrap the value in a mutable borrow with a fresh id *) - let bid = C.fresh_borrow_id () in - let rv_ty = T.Ref (T.Erased, v.ty, Mut) in - let rv : V.typed_value = - { V.value = V.Borrow (V.MutBorrow (bid, v)); ty = rv_ty } - in - (* Compute the value with which to replace the value at place p *) - let nv = { v with V.value = V.Loan (V.MutLoan bid) } in - (* Update the value in the context *) - let ctx = write_place_unwrap config access p nv ctx in - (* Continue *) - cf rv ctx - in - (* Compose and apply *) - comp prepare eval cf ctx - -let eval_rvalue_aggregate (config : C.config) - (aggregate_kind : E.aggregate_kind) (ops : E.operand list) - (cf : V.typed_value -> m_fun) : m_fun = - (* Evaluate the operands *) - let eval_ops = eval_operands config ops in - (* Compute the value *) - let compute (cf : V.typed_value -> m_fun) (values : V.typed_value list) : - m_fun = - fun ctx -> - (* Match on the aggregate kind *) - match aggregate_kind with - | E.AggregatedTuple -> - let tys = List.map (fun (v : V.typed_value) -> v.V.ty) values in - let v = V.Adt { variant_id = None; field_values = values } in - let ty = T.Adt (T.Tuple, [], tys) in - let aggregated : V.typed_value = { V.value = v; ty } in - (* Call the continuation *) - cf aggregated ctx - | E.AggregatedOption (variant_id, ty) -> - (* Sanity check *) - if variant_id == T.option_none_id then assert (values == []) - else if variant_id == T.option_some_id then - assert (List.length values == 1) - else raise (Failure "Unreachable"); - (* Construt the value *) - let aty = T.Adt (T.Assumed T.Option, [], [ ty ]) in - let av : V.adt_value = - { V.variant_id = Some variant_id; V.field_values = values } - in - let aggregated : V.typed_value = { V.value = Adt av; ty = aty } in - (* Call the continuation *) - cf aggregated ctx - | E.AggregatedAdt (def_id, opt_variant_id, regions, types) -> - (* Sanity checks *) - let type_decl = C.ctx_lookup_type_decl ctx def_id in - assert (List.length type_decl.region_params = List.length regions); - let expected_field_types = - Subst.ctx_adt_get_instantiated_field_etypes ctx def_id opt_variant_id - types - in - assert ( - expected_field_types - = List.map (fun (v : V.typed_value) -> v.V.ty) values); - (* Construct the value *) - let av : V.adt_value = - { V.variant_id = opt_variant_id; V.field_values = values } - in - let aty = T.Adt (T.AdtId def_id, regions, types) in - let aggregated : V.typed_value = { V.value = Adt av; ty = aty } in - (* Call the continuation *) - cf aggregated ctx - in - (* Compose and apply *) - comp eval_ops compute cf - -(** Evaluate an rvalue. - - Transmits the computed rvalue to the received continuation. - *) -let eval_rvalue (config : C.config) (rvalue : E.rvalue) - (cf : (V.typed_value, eval_error) result -> m_fun) : m_fun = - fun ctx -> - log#ldebug (lazy "eval_rvalue"); - (* Small helpers *) - let wrap_in_result (cf : (V.typed_value, eval_error) result -> m_fun) - (v : V.typed_value) : m_fun = - cf (Ok v) - in - let comp_wrap f = comp f wrap_in_result cf in - (* Delegate to the proper auxiliary function *) - match rvalue with - | E.Use op -> comp_wrap (eval_operand config op) ctx - | E.Ref (p, bkind) -> comp_wrap (eval_rvalue_ref config p bkind) ctx - | E.UnaryOp (unop, op) -> eval_unary_op config unop op cf ctx - | E.BinaryOp (binop, op1, op2) -> eval_binary_op config binop op1 op2 cf ctx - | E.Aggregate (aggregate_kind, ops) -> - comp_wrap (eval_rvalue_aggregate config aggregate_kind ops) ctx - | E.Discriminant p -> comp_wrap (eval_rvalue_discriminant config p) ctx diff --git a/src/InterpreterPaths.ml b/src/InterpreterPaths.ml deleted file mode 100644 index d54a046e..00000000 --- a/src/InterpreterPaths.ml +++ /dev/null @@ -1,801 +0,0 @@ -module T = Types -module V = Values -module E = Expressions -module C = Contexts -module Subst = Substitute -module L = Logging -open Cps -open TypesUtils -open ValuesUtils -open InterpreterUtils -open InterpreterBorrowsCore -open InterpreterBorrows -open InterpreterExpansion -module Synth = SynthesizeSymbolic - -(** The local logger *) -let log = L.paths_log - -(** Paths *) - -(** When we fail reading from or writing to a path, it might be because we - need to update the environment by ending borrows, expanding symbolic - values, etc. The following type is used to convey this information. - - TODO: compare with borrow_lres? -*) -type path_fail_kind = - | FailSharedLoan of V.BorrowId.Set.t - (** Failure because we couldn't go inside a shared loan *) - | FailMutLoan of V.BorrowId.id - (** Failure because we couldn't go inside a mutable loan *) - | FailInactivatedMutBorrow of V.BorrowId.id - (** Failure because we couldn't go inside an inactivated mutable borrow - (which should get activated) *) - | FailSymbolic of int * V.symbolic_value - (** Failure because we need to enter a symbolic value (and thus need to - expand it). - We return the number of elements which remained in the path when we - reached the error - this allows to retrieve the path prefix, which - is useful for the synthesis. *) - | FailBottom of int * E.projection_elem * T.ety - (** Failure because we need to enter an any value - we can expand Bottom - values if they are left values. We return the number of elements which - remained in the path when we reached the error - this allows to - properly update the Bottom value, if needs be. - *) - | FailBorrow of V.borrow_content - (** We got stuck because we couldn't enter a borrow *) - -(** Result of evaluating a path (reading from a path/writing to a path) - - Note that when we fail, we return information used to update the - environment, as well as the -*) -type 'a path_access_result = ('a, path_fail_kind) result -(** The result of reading from/writing to a place *) - -type updated_read_value = { read : V.typed_value; updated : V.typed_value } - -type projection_access = { - enter_shared_loans : bool; - enter_mut_borrows : bool; - lookup_shared_borrows : bool; -} - -(** Generic function to access (read/write) the value at the end of a projection. - - We return the (eventually) updated value, the value we read at the end of - the place and the (eventually) updated environment. - - TODO: use exceptions? - *) -let rec access_projection (access : projection_access) (ctx : C.eval_ctx) - (* Function to (eventually) update the value we find *) - (update : V.typed_value -> V.typed_value) (p : E.projection) - (v : V.typed_value) : (C.eval_ctx * updated_read_value) path_access_result = - (* For looking up/updating shared loans *) - let ek : exploration_kind = - { enter_shared_loans = true; enter_mut_borrows = true; enter_abs = true } - in - match p with - | [] -> - let nv = update v in - (* Type checking *) - if nv.ty <> v.ty then ( - log#lerror - (lazy - ("Not the same type:\n- nv.ty: " ^ T.show_ety nv.ty ^ "\n- v.ty: " - ^ T.show_ety v.ty)); - failwith - "Assertion failed: new value doesn't have the same type as its \ - destination"); - Ok (ctx, { read = v; updated = nv }) - | pe :: p' -> ( - (* Match on the projection element and the value *) - match (pe, v.V.value, v.V.ty) with - | ( Field (((ProjAdt (_, _) | ProjOption _) as proj_kind), field_id), - V.Adt adt, - T.Adt (type_id, _, _) ) -> ( - (* Check consistency *) - (match (proj_kind, type_id) with - | ProjAdt (def_id, opt_variant_id), T.AdtId def_id' -> - assert (def_id = def_id'); - assert (opt_variant_id = adt.variant_id) - | ProjOption variant_id, T.Assumed T.Option -> - assert (Some variant_id = adt.variant_id) - | _ -> failwith "Unreachable"); - (* Actually project *) - let fv = T.FieldId.nth adt.field_values field_id in - match access_projection access ctx update p' fv with - | Error err -> Error err - | Ok (ctx, res) -> - (* Update the field value *) - let nvalues = - T.FieldId.update_nth adt.field_values field_id res.updated - in - let nadt = V.Adt { adt with V.field_values = nvalues } in - let updated = { v with value = nadt } in - Ok (ctx, { res with updated })) - (* Tuples *) - | Field (ProjTuple arity, field_id), V.Adt adt, T.Adt (T.Tuple, _, _) -> ( - assert (arity = List.length adt.field_values); - let fv = T.FieldId.nth adt.field_values field_id in - (* Project *) - match access_projection access ctx update p' fv with - | Error err -> Error err - | Ok (ctx, res) -> - (* Update the field value *) - let nvalues = - T.FieldId.update_nth adt.field_values field_id res.updated - in - let ntuple = V.Adt { adt with field_values = nvalues } in - let updated = { v with value = ntuple } in - Ok (ctx, { res with updated }) - (* If we reach Bottom, it may mean we need to expand an uninitialized - * enumeration value *)) - | Field ((ProjAdt (_, _) | ProjTuple _ | ProjOption _), _), V.Bottom, _ -> - Error (FailBottom (1 + List.length p', pe, v.ty)) - (* Symbolic value: needs to be expanded *) - | _, Symbolic sp, _ -> - (* Expand the symbolic value *) - Error (FailSymbolic (1 + List.length p', sp)) - (* Box dereferencement *) - | ( DerefBox, - Adt { variant_id = None; field_values = [ bv ] }, - T.Adt (T.Assumed T.Box, _, _) ) -> ( - (* We allow moving inside of boxes. In practice, this kind of - * manipulations should happen only inside unsage code, so - * it shouldn't happen due to user code, and we leverage it - * when implementing box dereferencement for the concrete - * interpreter *) - match access_projection access ctx update p' bv with - | Error err -> Error err - | Ok (ctx, res) -> - let nv = - { - v with - value = - V.Adt { variant_id = None; field_values = [ res.updated ] }; - } - in - Ok (ctx, { res with updated = nv })) - (* Borrows *) - | Deref, V.Borrow bc, _ -> ( - match bc with - | V.SharedBorrow (_, bid) -> - (* Lookup the loan content, and explore from there *) - if access.lookup_shared_borrows then - match lookup_loan ek bid ctx with - | _, Concrete (V.MutLoan _) -> failwith "Expected a shared loan" - | _, Concrete (V.SharedLoan (bids, sv)) -> ( - (* Explore the shared value *) - match access_projection access ctx update p' sv with - | Error err -> Error err - | Ok (ctx, res) -> - (* Update the shared loan with the new value returned - by {!access_projection} *) - let ctx = - update_loan ek bid - (V.SharedLoan (bids, res.updated)) - ctx - in - (* Return - note that we don't need to update the borrow itself *) - Ok (ctx, { res with updated = v })) - | ( _, - Abstract - ( V.AMutLoan (_, _) - | V.AEndedMutLoan - { given_back = _; child = _; given_back_meta = _ } - | V.AEndedSharedLoan (_, _) - | V.AIgnoredMutLoan (_, _) - | V.AEndedIgnoredMutLoan - { given_back = _; child = _; given_back_meta = _ } - | V.AIgnoredSharedLoan _ ) ) -> - failwith "Expected a shared (abstraction) loan" - | _, Abstract (V.ASharedLoan (bids, sv, _av)) -> ( - (* Explore the shared value *) - match access_projection access ctx update p' sv with - | Error err -> Error err - | Ok (ctx, res) -> - (* Relookup the child avalue *) - let av = - match lookup_loan ek bid ctx with - | _, Abstract (V.ASharedLoan (_, _, av)) -> av - | _ -> failwith "Unexpected" - in - (* Update the shared loan with the new value returned - by {!access_projection} *) - let ctx = - update_aloan ek bid - (V.ASharedLoan (bids, res.updated, av)) - ctx - in - (* Return - note that we don't need to update the borrow itself *) - Ok (ctx, { res with updated = v })) - else Error (FailBorrow bc) - | V.InactivatedMutBorrow (_, bid) -> - Error (FailInactivatedMutBorrow bid) - | V.MutBorrow (bid, bv) -> - if access.enter_mut_borrows then - match access_projection access ctx update p' bv with - | Error err -> Error err - | Ok (ctx, res) -> - let nv = - { - v with - value = V.Borrow (V.MutBorrow (bid, res.updated)); - } - in - Ok (ctx, { res with updated = nv }) - else Error (FailBorrow bc)) - | _, V.Loan lc, _ -> ( - match lc with - | V.MutLoan bid -> Error (FailMutLoan bid) - | V.SharedLoan (bids, sv) -> - (* If we can enter shared loan, we ignore the loan. Pay attention - to the fact that we need to reexplore the *whole* place (i.e, - we mustn't ignore the current projection element *) - if access.enter_shared_loans then - match access_projection access ctx update (pe :: p') sv with - | Error err -> Error err - | Ok (ctx, res) -> - let nv = - { - v with - value = V.Loan (V.SharedLoan (bids, res.updated)); - } - in - Ok (ctx, { res with updated = nv }) - else Error (FailSharedLoan bids)) - | (_, (V.Concrete _ | V.Adt _ | V.Bottom | V.Borrow _), _) as r -> - let pe, v, ty = r in - let pe = "- pe: " ^ E.show_projection_elem pe in - let v = "- v:\n" ^ V.show_value v in - let ty = "- ty:\n" ^ T.show_ety ty in - log#serror ("Inconsistent projection:\n" ^ pe ^ "\n" ^ v ^ "\n" ^ ty); - failwith "Inconsistent projection") - -(** Generic function to access (read/write) the value at a given place. - - We return the value we read at the place and the (eventually) updated - environment, if we managed to access the place, or the precise reason - why we failed. - *) -let access_place (access : projection_access) - (* Function to (eventually) update the value we find *) - (update : V.typed_value -> V.typed_value) (p : E.place) (ctx : C.eval_ctx) - : (C.eval_ctx * V.typed_value) path_access_result = - (* Lookup the variable's value *) - let value = C.ctx_lookup_var_value ctx p.var_id in - (* Apply the projection *) - match access_projection access ctx update p.projection value with - | Error err -> Error err - | Ok (ctx, res) -> - (* Update the value *) - let ctx = C.ctx_update_var_value ctx p.var_id res.updated in - (* Return *) - Ok (ctx, res.read) - -type access_kind = - | Read (** We can go inside borrows and loans *) - | Write (** Don't enter shared borrows or shared loans *) - | Move (** Don't enter borrows or loans *) - -let access_kind_to_projection_access (access : access_kind) : projection_access - = - match access with - | Read -> - { - enter_shared_loans = true; - enter_mut_borrows = true; - lookup_shared_borrows = true; - } - | Write -> - { - enter_shared_loans = false; - enter_mut_borrows = true; - lookup_shared_borrows = false; - } - | Move -> - { - enter_shared_loans = false; - enter_mut_borrows = false; - lookup_shared_borrows = false; - } - -(** Read the value at a given place. - - Note that we only access the value at the place, and do not check that - the value is "well-formed" (for instance that it doesn't contain bottoms). - *) -let read_place (config : C.config) (access : access_kind) (p : E.place) - (ctx : C.eval_ctx) : V.typed_value path_access_result = - let access = access_kind_to_projection_access access in - (* The update function is the identity *) - let update v = v in - match access_place access update p ctx with - | Error err -> Error err - | Ok (ctx1, read_value) -> - (* Note that we ignore the new environment: it should be the same as the - original one. - *) - if config.check_invariants then - if ctx1 <> ctx then ( - let msg = - "Unexpected environment update:\nNew environment:\n" - ^ C.show_env ctx1.env ^ "\n\nOld environment:\n" - ^ C.show_env ctx.env - in - log#serror msg; - failwith "Unexpected environment update"); - Ok read_value - -let read_place_unwrap (config : C.config) (access : access_kind) (p : E.place) - (ctx : C.eval_ctx) : V.typed_value = - match read_place config access p ctx with - | Error _ -> failwith "Unreachable" - | Ok v -> v - -(** Update the value at a given place *) -let write_place (_config : C.config) (access : access_kind) (p : E.place) - (nv : V.typed_value) (ctx : C.eval_ctx) : C.eval_ctx path_access_result = - let access = access_kind_to_projection_access access in - (* The update function substitutes the value with the new value *) - let update _ = nv in - match access_place access update p ctx with - | Error err -> Error err - | Ok (ctx, _) -> - (* We ignore the read value *) - Ok ctx - -let write_place_unwrap (config : C.config) (access : access_kind) (p : E.place) - (nv : V.typed_value) (ctx : C.eval_ctx) : C.eval_ctx = - match write_place config access p nv ctx with - | Error _ -> failwith "Unreachable" - | Ok ctx -> ctx - -(** Compute an expanded ADT bottom value *) -let compute_expanded_bottom_adt_value (tyctx : T.type_decl T.TypeDeclId.Map.t) - (def_id : T.TypeDeclId.id) (opt_variant_id : T.VariantId.id option) - (regions : T.erased_region list) (types : T.ety list) : V.typed_value = - (* Lookup the definition and check if it is an enumeration - it - should be an enumeration if and only if the projection element - is a field projection with *some* variant id. Retrieve the list - of fields at the same time. *) - let def = T.TypeDeclId.Map.find def_id tyctx in - assert (List.length regions = List.length def.T.region_params); - (* Compute the field types *) - let field_types = - Subst.type_decl_get_instantiated_field_etypes def opt_variant_id types - in - (* Initialize the expanded value *) - let fields = List.map mk_bottom field_types in - let av = V.Adt { variant_id = opt_variant_id; field_values = fields } in - let ty = T.Adt (T.AdtId def_id, regions, types) in - { V.value = av; V.ty } - -(** Compute an expanded Option bottom value *) -let compute_expanded_bottom_option_value (variant_id : T.VariantId.id) - (param_ty : T.ety) : V.typed_value = - (* Note that the variant can be [Some] or [None]: we expand bottom values - * when writing to fields or setting discriminants *) - let field_values = - if variant_id = T.option_some_id then [ mk_bottom param_ty ] - else if variant_id = T.option_none_id then [] - else raise (Failure "Unreachable") - in - let av = V.Adt { variant_id = Some variant_id; field_values } in - let ty = T.Adt (T.Assumed T.Option, [], [ param_ty ]) in - { V.value = av; ty } - -(** Compute an expanded tuple bottom value *) -let compute_expanded_bottom_tuple_value (field_types : T.ety list) : - V.typed_value = - (* Generate the field values *) - let fields = List.map mk_bottom field_types in - let v = V.Adt { variant_id = None; field_values = fields } in - let ty = T.Adt (T.Tuple, [], field_types) in - { V.value = v; V.ty } - -(** Auxiliary helper to expand {!V.Bottom} values. - - During compilation, rustc desaggregates the ADT initializations. The - consequence is that the following rust code: - {[ - let x = Cons a b; - ]} - - Looks like this in MIR: - {[ - (x as Cons).0 = a; - (x as Cons).1 = b; - set_discriminant(x, 0); // If [Cons] is the variant of index 0 - ]} - - The consequence is that we may sometimes need to write fields to values - which are currently {!V.Bottom}. When doing this, we first expand the value - to, say, [Cons Bottom Bottom] (note that field projection contains information - about which variant we should project to, which is why we *can* set the - variant index when writing one of its fields). -*) -let expand_bottom_value_from_projection (config : C.config) - (access : access_kind) (p : E.place) (remaining_pes : int) - (pe : E.projection_elem) (ty : T.ety) (ctx : C.eval_ctx) : C.eval_ctx = - (* Debugging *) - log#ldebug - (lazy - ("expand_bottom_value_from_projection:\n" ^ "pe: " - ^ E.show_projection_elem pe ^ "\n" ^ "ty: " ^ T.show_ety ty)); - (* Prepare the update: we need to take the proper prefix of the place - during whose evaluation we got stuck *) - let projection' = - fst - (Collections.List.split_at p.projection - (List.length p.projection - remaining_pes)) - in - let p' = { p with projection = projection' } in - (* Compute the expanded value. - The type of the {!V.Bottom} value should be a tuple or an ADT. - Note that the projection element we got stuck at should be a - field projection, and gives the variant id if the {!V.Bottom} value - is an enumeration value. - Also, the expanded value should be the proper ADT variant or a tuple - with the proper arity, with all the fields initialized to {!V.Bottom} - *) - let nv = - match (pe, ty) with - (* "Regular" ADTs *) - | ( Field (ProjAdt (def_id, opt_variant_id), _), - T.Adt (T.AdtId def_id', regions, types) ) -> - assert (def_id = def_id'); - compute_expanded_bottom_adt_value ctx.type_context.type_decls def_id - opt_variant_id regions types - (* Option *) - | Field (ProjOption variant_id, _), T.Adt (T.Assumed T.Option, [], [ ty ]) - -> - compute_expanded_bottom_option_value variant_id ty - (* Tuples *) - | Field (ProjTuple arity, _), T.Adt (T.Tuple, [], tys) -> - assert (arity = List.length tys); - (* Generate the field values *) - compute_expanded_bottom_tuple_value tys - | _ -> - failwith - ("Unreachable: " ^ E.show_projection_elem pe ^ ", " ^ T.show_ety ty) - in - (* Update the context by inserting the expanded value at the proper place *) - match write_place config access p' nv ctx with - | Ok ctx -> ctx - | Error _ -> failwith "Unreachable" - -(** Update the environment to be able to read a place. - - When reading a place, we may be stuck along the way because some value - is borrowed, we reach a symbolic value, etc. In this situation [read_place] - fails while returning precise information about the failure. This function - uses this information to update the environment (by ending borrows, - expanding symbolic values) until we manage to fully read the place. - *) -let rec update_ctx_along_read_place (config : C.config) (access : access_kind) - (p : E.place) : cm_fun = - fun cf ctx -> - (* Attempt to read the place: if it fails, update the environment and retry *) - match read_place config access p ctx with - | Ok _ -> cf ctx - | Error err -> - let cc = - match err with - | FailSharedLoan bids -> end_outer_borrows config bids - | FailMutLoan bid -> end_outer_borrow config bid - | FailInactivatedMutBorrow bid -> - activate_inactivated_mut_borrow config bid - | FailSymbolic (i, sp) -> - (* Expand the symbolic value *) - let proj, _ = - Collections.List.split_at p.projection - (List.length p.projection - i) - in - let prefix = { p with projection = proj } in - expand_symbolic_value_no_branching config sp - (Some (Synth.mk_mplace prefix ctx)) - | FailBottom (_, _, _) -> - (* We can't expand {!V.Bottom} values while reading them *) - failwith "Found [Bottom] while reading a place" - | FailBorrow _ -> failwith "Could not read a borrow" - in - comp cc (update_ctx_along_read_place config access p) cf ctx - -(** Update the environment to be able to write to a place. - - See {!update_ctx_along_read_place}. -*) -let rec update_ctx_along_write_place (config : C.config) (access : access_kind) - (p : E.place) : cm_fun = - fun cf ctx -> - (* Attempt to *read* (yes, *read*: we check the access to the place, and - write to it later) the place: if it fails, update the environment and retry *) - match read_place config access p ctx with - | Ok _ -> cf ctx - | Error err -> - (* Update the context *) - let cc = - match err with - | FailSharedLoan bids -> end_outer_borrows config bids - | FailMutLoan bid -> end_outer_borrow config bid - | FailInactivatedMutBorrow bid -> - activate_inactivated_mut_borrow config bid - | FailSymbolic (_pe, sp) -> - (* Expand the symbolic value *) - expand_symbolic_value_no_branching config sp - (Some (Synth.mk_mplace p ctx)) - | FailBottom (remaining_pes, pe, ty) -> - (* Expand the {!V.Bottom} value *) - fun cf ctx -> - let ctx = - expand_bottom_value_from_projection config access p remaining_pes - pe ty ctx - in - cf ctx - | FailBorrow _ -> failwith "Could not write to a borrow" - in - (* Retry *) - comp cc (update_ctx_along_write_place config access p) cf ctx - -(** Small utility used to break control-flow *) -exception UpdateCtx of cm_fun - -(** End the loans at a given place: read the value, if it contains a loan, - end this loan, repeat. - - This is used when reading or borrowing values. We typically - first call {!update_ctx_along_read_place} or {!update_ctx_along_write_place} - to get access to the value, then call this function to "prepare" the value: - when moving values, we can't move a value which contains loans and thus need - to end them, etc. - *) -let rec end_loans_at_place (config : C.config) (access : access_kind) - (p : E.place) : cm_fun = - fun cf ctx -> - (* Iterator to explore a value and update the context whenever we find - * loans. - * We use exceptions to make it handy: whenever we update the - * context, we raise an exception wrapping the updated context. - * *) - let obj = - object - inherit [_] V.iter_typed_value as super - - method! visit_borrow_content env bc = - match bc with - | V.SharedBorrow _ | V.MutBorrow (_, _) -> - (* Nothing special to do *) super#visit_borrow_content env bc - | V.InactivatedMutBorrow (_, bid) -> - (* We need to activate inactivated borrows *) - let cc = activate_inactivated_mut_borrow config bid in - raise (UpdateCtx cc) - - method! visit_loan_content env lc = - match lc with - | V.SharedLoan (bids, v) -> ( - (* End the loans if we need a modification access, otherwise dive into - the shared value *) - match access with - | Read -> super#visit_SharedLoan env bids v - | Write | Move -> - let cc = end_outer_borrows config bids in - raise (UpdateCtx cc)) - | V.MutLoan bid -> - (* We always need to end mutable borrows *) - let cc = end_outer_borrow config bid in - raise (UpdateCtx cc) - end - in - - (* First, retrieve the value *) - match read_place config access p ctx with - | Error _ -> failwith "Unreachable" - | Ok v -> ( - (* Inspect the value and update the context while doing so. - If the context gets updated: perform a recursive call (many things - may have been updated in the context: we need to re-read the value - at place [p] - and this value may actually not be accessible - anymore...) - *) - try - obj#visit_typed_value () v; - (* No context update required: apply the continuation *) - cf ctx - with UpdateCtx cc -> - (* We need to update the context: compose the caugth continuation with - * a recursive call to reinspect the value *) - comp cc (end_loans_at_place config access p) cf ctx) - -(** Drop (end) outer loans and borrows at a given place, which should be - seen as an l-value (we will write to it later, but need to drop - the borrows before writing). - - This is used to drop values when evaluating the drop statement or before - writing to a place. - - [end_borrows]: - - if true: end all the loans and borrows we find, starting with the outer - ones. This is used when evaluating the [drop] statement (see [drop_value]) - - if false: only end the outer loans. This is used by [assign_to_place] - or to drop the loans in the local variables when popping a frame. - - Note that we don't do what is defined in the formalization: we move the - value to a temporary dummy value, then explore this value and end the - loans/borrows inside as long as we find some, starting with the outer - ones, then move the resulting value back to where it was. This shouldn't - make any difference, really (note that the place is *inside* a borrow, - if we end the borrow, we won't be able to reinsert the value back). - *) -let drop_outer_borrows_loans_at_lplace (config : C.config) (end_borrows : bool) - (p : E.place) : cm_fun = - fun cf ctx -> - (* Move the current value in the place outside of this place and into - * a dummy variable *) - let access = Write in - let v = read_place_unwrap config access p ctx in - let ctx = write_place_unwrap config access p (mk_bottom v.V.ty) ctx in - let ctx = C.ctx_push_dummy_var ctx v in - (* Auxiliary function *) - let rec drop : cm_fun = - fun cf ctx -> - (* Read the value *) - let v = C.ctx_read_first_dummy_var ctx in - (* Check if there are loans or borrows to end *) - match get_first_outer_loan_or_borrow_in_value end_borrows v with - | None -> - (* We are done: simply call the continuation *) - cf ctx - | Some c -> - (* There are: end them then retry *) - let cc = - match c with - | LoanContent (V.SharedLoan (bids, _)) -> - end_outer_borrows config bids - | LoanContent (V.MutLoan bid) - | BorrowContent (V.MutBorrow (bid, _) | SharedBorrow (_, bid)) -> - end_outer_borrow config bid - | BorrowContent (V.InactivatedMutBorrow (_, bid)) -> - (* First activate the borrow *) - activate_inactivated_mut_borrow config bid - in - (* Retry *) - comp cc drop cf ctx - in - (* Apply the drop function *) - let cc = drop in - (* Pop the temporary value and reinsert it *) - let cc = - comp cc (fun cf ctx -> - (* Pop *) - let ctx, v = C.ctx_pop_dummy_var ctx in - (* Reinsert *) - let ctx = write_place_unwrap config access p v ctx in - (* Sanity check *) - if end_borrows then ( - assert (not (loans_in_value v)); - assert (not (borrows_in_value v))) - else assert (not (outer_loans_in_value v)); - (* Continue *) - cf ctx) - in - (* Continue *) - cc cf ctx - -(** Copy a value, and return the resulting value. - - Note that copying values might update the context. For instance, when - copying shared borrows, we need to insert new shared borrows in the context. - - Also, this function is actually more general than it should be: it can be used - to copy concrete ADT values, while ADT copy should be done through the Copy - trait (i.e., by calling a dedicated function). This is why we added a parameter - to control this copy. Note that here by ADT we mean the user-defined ADTs - (not tuples or assumed types). - - TODO: move - *) -let rec copy_value (allow_adt_copy : bool) (config : C.config) - (ctx : C.eval_ctx) (v : V.typed_value) : C.eval_ctx * V.typed_value = - log#ldebug - (lazy - ("copy_value: " - ^ typed_value_to_string ctx v - ^ "\n- context:\n" ^ eval_ctx_to_string ctx)); - (* Remark: at some point we rewrote this function to use iterators, but then - * we reverted the changes: the result was less clear actually. In particular, - * the fact that we have exhaustive matches below makes very obvious the cases - * in which we need to fail *) - match v.V.value with - | V.Concrete _ -> (ctx, v) - | V.Adt av -> - (* Sanity check *) - (match v.V.ty with - | T.Adt (T.Assumed (T.Box | Vec), _, _) -> - failwith "Can't copy an assumed value other than Option" - | T.Adt (T.AdtId _, _, _) -> assert allow_adt_copy - | T.Adt ((T.Assumed Option | T.Tuple), _, _) -> () (* Ok *) - | _ -> failwith "Unreachable"); - let ctx, fields = - List.fold_left_map - (copy_value allow_adt_copy config) - ctx av.field_values - in - (ctx, { v with V.value = V.Adt { av with field_values = fields } }) - | V.Bottom -> failwith "Can't copy ⊥" - | V.Borrow bc -> ( - (* We can only copy shared borrows *) - match bc with - | SharedBorrow (mv, bid) -> - (* We need to create a new borrow id for the copied borrow, and - * update the context accordingly *) - let bid' = C.fresh_borrow_id () in - let ctx = reborrow_shared bid bid' ctx in - (ctx, { v with V.value = V.Borrow (SharedBorrow (mv, bid')) }) - | MutBorrow (_, _) -> failwith "Can't copy a mutable borrow" - | V.InactivatedMutBorrow _ -> - failwith "Can't copy an inactivated mut borrow") - | V.Loan lc -> ( - (* We can only copy shared loans *) - match lc with - | V.MutLoan _ -> failwith "Can't copy a mutable loan" - | V.SharedLoan (_, sv) -> - (* We don't copy the shared loan: only the shared value inside *) - copy_value allow_adt_copy config ctx sv) - | V.Symbolic sp -> - (* We can copy only if the type is "primitively" copyable. - * Note that in the general case, copy is a trait: copying values - * thus requires calling the proper function. Here, we copy values - * for very simple types such as integers, shared borrows, etc. *) - assert (ty_is_primitively_copyable (Subst.erase_regions sp.V.sv_ty)); - (* If the type is copyable, we simply return the current value. Side - * remark: what is important to look at when copying symbolic values - * is symbolic expansion. The important subcase is the expansion of shared - * borrows: when doing so, every occurrence of the same symbolic value - * must use a fresh borrow id. *) - (ctx, v) - -(** Small utility. - - Prepare a place which is to be used as the destination of an assignment: - update the environment along the paths, end the loans at this place, etc. - - Return the updated context and the (updated) value at the end of the - place. This value should not contain any loan or borrow (and we check - it is the case). Note that this value is very likely to contain {!V.Bottom} - subvalues. - - [end_borrows]: if false, we only end the outer loans we find. If true, we - end all the loans and the borrows we find. - TODO: end_borrows is not necessary anymore. - *) -let prepare_lplace (config : C.config) (end_borrows : bool) (p : E.place) - (cf : V.typed_value -> m_fun) : m_fun = - fun ctx -> - log#ldebug - (lazy - ("prepare_lplace:" ^ "\n- p: " ^ place_to_string ctx p - ^ "\n- Initial context:\n" ^ eval_ctx_to_string ctx)); - (* Access the place *) - let access = Write in - let cc = update_ctx_along_write_place config access p in - (* End the borrows and loans, starting with the borrows *) - let cc = comp cc (drop_outer_borrows_loans_at_lplace config end_borrows p) in - (* Read the value and check it *) - let read_check cf : m_fun = - fun ctx -> - let v = read_place_unwrap config access p ctx in - (* Sanity checks *) - if end_borrows then ( - assert (not (loans_in_value v)); - assert (not (borrows_in_value v))) - else assert (not (outer_loans_in_value v)); - (* Continue *) - cf v ctx - in - (* Compose and apply the continuations *) - comp cc read_check cf ctx diff --git a/src/InterpreterProjectors.ml b/src/InterpreterProjectors.ml deleted file mode 100644 index 064b8969..00000000 --- a/src/InterpreterProjectors.ml +++ /dev/null @@ -1,543 +0,0 @@ -module T = Types -module V = Values -module E = Expressions -module C = Contexts -module Subst = Substitute -module L = Logging -open TypesUtils -open InterpreterUtils -open InterpreterBorrowsCore - -(** Auxiliary function. - - Apply a proj_borrows on a shared borrow. - Note that when projecting over shared values, we generate - {!V.abstract_shared_borrows}, not {!V.avalue}s. -*) -let rec apply_proj_borrows_on_shared_borrow (ctx : C.eval_ctx) - (fresh_reborrow : V.BorrowId.id -> V.BorrowId.id) - (regions : T.RegionId.Set.t) (v : V.typed_value) (ty : T.rty) : - V.abstract_shared_borrows = - (* Sanity check - TODO: move this elsewhere (here we perform the check at every - * recursive call which is a bit overkill...) *) - let ety = Subst.erase_regions ty in - assert (ety = v.V.ty); - (* Project - if there are no regions from the abstraction in the type, return [_] *) - if not (ty_has_regions_in_set regions ty) then [] - else - match (v.V.value, ty) with - | V.Concrete _, (T.Bool | T.Char | T.Integer _ | T.Str) -> [] - | V.Adt adt, T.Adt (id, region_params, tys) -> - (* Retrieve the types of the fields *) - let field_types = - Subst.ctx_adt_value_get_instantiated_field_rtypes ctx adt id - region_params tys - in - (* Project over the field values *) - let fields_types = List.combine adt.V.field_values field_types in - let proj_fields = - List.map - (fun (fv, fty) -> - apply_proj_borrows_on_shared_borrow ctx fresh_reborrow regions fv - fty) - fields_types - in - List.concat proj_fields - | V.Bottom, _ -> failwith "Unreachable" - | V.Borrow bc, T.Ref (r, ref_ty, kind) -> - (* Retrieve the bid of the borrow and the asb of the projected borrowed value *) - let bid, asb = - (* Not in the set: dive *) - match (bc, kind) with - | V.MutBorrow (bid, bv), T.Mut -> - (* Apply the projection on the borrowed value *) - let asb = - apply_proj_borrows_on_shared_borrow ctx fresh_reborrow regions - bv ref_ty - in - (bid, asb) - | V.SharedBorrow (_, bid), T.Shared -> - (* Lookup the shared value *) - let ek = ek_all in - let sv = lookup_loan ek bid ctx in - let asb = - match sv with - | _, Concrete (V.SharedLoan (_, sv)) - | _, Abstract (V.ASharedLoan (_, sv, _)) -> - apply_proj_borrows_on_shared_borrow ctx fresh_reborrow - regions sv ref_ty - | _ -> failwith "Unexpected" - in - (bid, asb) - | V.InactivatedMutBorrow _, _ -> - failwith - "Can't apply a proj_borrow over an inactivated mutable borrow" - | _ -> failwith "Unreachable" - in - let asb = - (* Check if the region is in the set of projected regions (note that - * we never project over static regions) *) - if region_in_set r regions then - let bid' = fresh_reborrow bid in - V.AsbBorrow bid' :: asb - else asb - in - asb - | V.Loan _, _ -> failwith "Unreachable" - | V.Symbolic s, _ -> - (* Check that the projection doesn't contain ended regions *) - assert ( - not (projections_intersect s.V.sv_ty ctx.ended_regions ty regions)); - [ V.AsbProjReborrows (s, ty) ] - | _ -> failwith "Unreachable" - -(** Apply (and reduce) a projector over borrows to a value. - - - [regions]: the regions we project - - [v]: the value over which we project - - [ty]: the projection type (is used to map borrows to regions, or to - interpret the borrows as belonging to some regions...). Remember that - [v] doesn't contain region information. - For instance, if we have: - [v <: ty] where: - - [v = mut_borrow l ...] - - [ty = Ref (r, ...)] - then we interpret the borrow [l] as belonging to region [r] - - Also, when applying projections on shared values, we need to apply - reborrows. This is a bit annoying because, with the way we compute - the projection on borrows, we can't update the context immediately. - Instead, we remember the list of borrows we have to insert in the - context *afterwards*. - - [check_symbolic_no_ended] controls whether we check or not whether - symbolic values don't contain already ended regions. - This check is activated when applying projectors upon calling a function - (because we need to check that function arguments don't contain ⊥), - but deactivated when expanding symbolic values: - {[ - fn f<'a,'b>(x : &'a mut u32, y : &'b mut u32) -> (&'a mut u32, &'b mut u32); - - let p = f(&mut x, &mut y); // p -> @s0 - assert(x == ...); // end 'a - let z = p.1; // HERE: the symbolic expansion of @s0 contains ended regions - ]} -*) -let rec apply_proj_borrows (check_symbolic_no_ended : bool) (ctx : C.eval_ctx) - (fresh_reborrow : V.BorrowId.id -> V.BorrowId.id) - (regions : T.RegionId.Set.t) (ancestors_regions : T.RegionId.Set.t) - (v : V.typed_value) (ty : T.rty) : V.typed_avalue = - (* Sanity check - TODO: move this elsewhere (here we perform the check at every - * recursive call which is a bit overkill...) *) - let ety = Substitute.erase_regions ty in - assert (ety = v.V.ty); - (* Project - if there are no regions from the abstraction in the type, return [_] *) - if not (ty_has_regions_in_set regions ty) then { V.value = V.AIgnored; ty } - else - let value : V.avalue = - match (v.V.value, ty) with - | V.Concrete cv, (T.Bool | T.Char | T.Integer _ | T.Str) -> V.AConcrete cv - | V.Adt adt, T.Adt (id, region_params, tys) -> - (* Retrieve the types of the fields *) - let field_types = - Subst.ctx_adt_value_get_instantiated_field_rtypes ctx adt id - region_params tys - in - (* Project over the field values *) - let fields_types = List.combine adt.V.field_values field_types in - let proj_fields = - List.map - (fun (fv, fty) -> - apply_proj_borrows check_symbolic_no_ended ctx fresh_reborrow - regions ancestors_regions fv fty) - fields_types - in - V.AAdt { V.variant_id = adt.V.variant_id; field_values = proj_fields } - | V.Bottom, _ -> failwith "Unreachable" - | V.Borrow bc, T.Ref (r, ref_ty, kind) -> - if - (* Check if the region is in the set of projected regions (note that - * we never project over static regions) *) - region_in_set r regions - then - (* In the set *) - let bc = - match (bc, kind) with - | V.MutBorrow (bid, bv), T.Mut -> - (* Remember the borrowed value we are about to project as a meta-value *) - let mv = bv in - (* Apply the projection on the borrowed value *) - let bv = - apply_proj_borrows check_symbolic_no_ended ctx - fresh_reborrow regions ancestors_regions bv ref_ty - in - V.AMutBorrow (mv, bid, bv) - | V.SharedBorrow (_, bid), T.Shared -> V.ASharedBorrow bid - | V.InactivatedMutBorrow _, _ -> - failwith - "Can't apply a proj_borrow over an inactivated mutable \ - borrow" - | _ -> failwith "Unreachable" - in - V.ABorrow bc - else - (* Not in the set: ignore *) - let bc = - match (bc, kind) with - | V.MutBorrow (bid, bv), T.Mut -> - (* Apply the projection on the borrowed value *) - let bv = - apply_proj_borrows check_symbolic_no_ended ctx - fresh_reborrow regions ancestors_regions bv ref_ty - in - (* If the borrow id is in the ancestor's regions, we still need - * to remember it *) - let opt_bid = - if region_in_set r ancestors_regions then Some bid else None - in - (* Return *) - V.AIgnoredMutBorrow (opt_bid, bv) - | V.SharedBorrow (_, bid), T.Shared -> - (* Lookup the shared value *) - let ek = ek_all in - let sv = lookup_loan ek bid ctx in - let asb = - match sv with - | _, Concrete (V.SharedLoan (_, sv)) - | _, Abstract (V.ASharedLoan (_, sv, _)) -> - apply_proj_borrows_on_shared_borrow ctx fresh_reborrow - regions sv ref_ty - | _ -> failwith "Unexpected" - in - V.AProjSharedBorrow asb - | V.InactivatedMutBorrow _, _ -> - failwith - "Can't apply a proj_borrow over an inactivated mutable \ - borrow" - | _ -> failwith "Unreachable" - in - V.ABorrow bc - | V.Loan _, _ -> failwith "Unreachable" - | V.Symbolic s, _ -> - (* Check that the projection doesn't contain already ended regions, - * if necessary *) - if check_symbolic_no_ended then ( - let ty1 = s.V.sv_ty in - let rset1 = ctx.ended_regions in - let ty2 = ty in - let rset2 = regions in - log#ldebug - (lazy - ("projections_intersect:" ^ "\n- ty1: " ^ rty_to_string ctx ty1 - ^ "\n- rset1: " - ^ T.RegionId.Set.to_string None rset1 - ^ "\n- ty2: " ^ rty_to_string ctx ty2 ^ "\n- rset2: " - ^ T.RegionId.Set.to_string None rset2 - ^ "\n")); - assert (not (projections_intersect ty1 rset1 ty2 rset2))); - V.ASymbolic (V.AProjBorrows (s, ty)) - | _ -> - log#lerror - (lazy - ("apply_proj_borrows: unexpected inputs:\n- input value: " - ^ typed_value_to_string ctx v - ^ "\n- proj rty: " ^ rty_to_string ctx ty)); - failwith "Unreachable" - in - { V.value; V.ty } - -(** Convert a symbolic expansion *which is not a borrow* to a value *) -let symbolic_expansion_non_borrow_to_value (sv : V.symbolic_value) - (see : V.symbolic_expansion) : V.typed_value = - let ty = Subst.erase_regions sv.V.sv_ty in - let value = - match see with - | SeConcrete cv -> V.Concrete cv - | SeAdt (variant_id, field_values) -> - let field_values = - List.map mk_typed_value_from_symbolic_value field_values - in - V.Adt { V.variant_id; V.field_values } - | SeMutRef (_, _) | SeSharedRef (_, _) -> - failwith "Unexpected symbolic reference expansion" - in - { V.value; V.ty } - -(** Convert a symbolic expansion to a value. - - If the expansion is a mutable reference expansion, it converts it to a borrow. - This function is meant to be used when reducing projectors over borrows, - during a symbolic expansion. - *) -let symbolic_expansion_non_shared_borrow_to_value (sv : V.symbolic_value) - (see : V.symbolic_expansion) : V.typed_value = - match see with - | SeMutRef (bid, bv) -> - let ty = Subst.erase_regions sv.V.sv_ty in - let bv = mk_typed_value_from_symbolic_value bv in - let value = V.Borrow (V.MutBorrow (bid, bv)) in - { V.value; ty } - | SeSharedRef (_, _) -> - failwith "Unexpected symbolic shared reference expansion" - | _ -> symbolic_expansion_non_borrow_to_value sv see - -(** Apply (and reduce) a projector over loans to a value. - - TODO: detailed comments. See [apply_proj_borrows] -*) -let apply_proj_loans_on_symbolic_expansion (regions : T.RegionId.Set.t) - (see : V.symbolic_expansion) (original_sv_ty : T.rty) : V.typed_avalue = - (* Sanity check: if we have a proj_loans over a symbolic value, it should - * contain regions which we will project *) - assert (ty_has_regions_in_set regions original_sv_ty); - (* Match *) - let (value, ty) : V.avalue * T.rty = - match (see, original_sv_ty) with - | SeConcrete _, (T.Bool | T.Char | T.Integer _ | T.Str) -> - (V.AIgnored, original_sv_ty) - | SeAdt (variant_id, field_values), T.Adt (_id, _region_params, _tys) -> - (* Project over the field values *) - let field_values = - List.map - (mk_aproj_loans_value_from_symbolic_value regions) - field_values - in - (V.AAdt { V.variant_id; field_values }, original_sv_ty) - | SeMutRef (bid, spc), T.Ref (r, ref_ty, T.Mut) -> - (* Sanity check *) - assert (spc.V.sv_ty = ref_ty); - (* Apply the projector to the borrowed value *) - let child_av = mk_aproj_loans_value_from_symbolic_value regions spc in - (* Check if the region is in the set of projected regions (note that - * we never project over static regions) *) - if region_in_set r regions then - (* In the set: keep *) - (V.ALoan (V.AMutLoan (bid, child_av)), ref_ty) - else - (* Not in the set: ignore *) - (V.ALoan (V.AIgnoredMutLoan (bid, child_av)), ref_ty) - | SeSharedRef (bids, spc), T.Ref (r, ref_ty, T.Shared) -> - (* Sanity check *) - assert (spc.V.sv_ty = ref_ty); - (* Apply the projector to the borrowed value *) - let child_av = mk_aproj_loans_value_from_symbolic_value regions spc in - (* Check if the region is in the set of projected regions (note that - * we never project over static regions) *) - if region_in_set r regions then - (* In the set: keep *) - let shared_value = mk_typed_value_from_symbolic_value spc in - (V.ALoan (V.ASharedLoan (bids, shared_value, child_av)), ref_ty) - else - (* Not in the set: ignore *) - (V.ALoan (V.AIgnoredSharedLoan child_av), ref_ty) - | _ -> failwith "Unreachable" - in - { V.value; V.ty } - -(** Auxiliary function. See [give_back_value]. - - Apply reborrows to a context. - - The [reborrows] input is a list of pairs (shared loan id, id to insert - in the shared loan). - This function is used when applying projectors on shared borrows: when - doing so, we might need to reborrow subvalues from the shared value. - For instance: - {[ - fn f<'a,'b,'c>(x : &'a 'b 'c u32) - ]} - When introducing the abstractions for 'a, 'b and 'c, we apply a projector - on some value [shared_borrow l : &'a &'b &'c u32]. - In the 'a abstraction, this shared borrow gets projected. However, when - reducing the projectors for the 'b and 'c abstractions, we need to make - sure that the borrows living in regions 'b and 'c live as long as those - regions. This is done by looking up the shared value and applying reborrows - on the borrows we find there (note that those reborrows apply on shared - borrows - easy - and mutable borrows - in this case, we reborrow the whole - borrow: [mut_borrow ... ~~> shared_loan {...} (mut_borrow ...)]). -*) -let apply_reborrows (reborrows : (V.BorrowId.id * V.BorrowId.id) list) - (ctx : C.eval_ctx) : C.eval_ctx = - (* This is a bit brutal, but whenever we insert a reborrow, we remove - * it from the list. This allows us to check that all the reborrows were - * applied before returning. - * We might reimplement that in a more efficient manner by using maps. *) - let reborrows = ref reborrows in - - (* Check if a value is a mutable borrow, and return its identifier if - it is the case *) - let get_borrow_in_mut_borrow (v : V.typed_value) : V.BorrowId.id option = - match v.V.value with - | V.Borrow lc -> ( - match lc with - | V.SharedBorrow (_, _) | V.InactivatedMutBorrow _ -> None - | V.MutBorrow (id, _) -> Some id) - | _ -> None - in - - (* Add the proper reborrows to a set of borrow ids (for a shared loan) *) - let insert_reborrows bids = - (* Find the reborrows to apply *) - let insert, reborrows' = - List.partition (fun (bid, _) -> V.BorrowId.Set.mem bid bids) !reborrows - in - reborrows := reborrows'; - let insert = List.map snd insert in - (* Insert the borrows *) - List.fold_left (fun bids bid -> V.BorrowId.Set.add bid bids) bids insert - in - - (* Get the list of reborrows for a given borrow id *) - let get_reborrows_for_bid bid = - (* Find the reborrows to apply *) - let insert, reborrows' = - List.partition (fun (bid', _) -> bid' = bid) !reborrows - in - reborrows := reborrows'; - List.map snd insert - in - - let borrows_to_set bids = - List.fold_left - (fun bids bid -> V.BorrowId.Set.add bid bids) - V.BorrowId.Set.empty bids - in - - (* Insert reborrows for a given borrow id into a given set of borrows *) - let insert_reborrows_for_bid bids bid = - (* Find the reborrows to apply *) - let insert = get_reborrows_for_bid bid in - (* Insert the borrows *) - List.fold_left (fun bids bid -> V.BorrowId.Set.add bid bids) bids insert - in - - let obj = - object - inherit [_] C.map_eval_ctx as super - - (** We may need to reborrow mutable borrows. Note that this doesn't - happen for aborrows *) - method! visit_typed_value env v = - match v.V.value with - | V.Borrow (V.MutBorrow (bid, bv)) -> - let insert = get_reborrows_for_bid bid in - let nbc = super#visit_MutBorrow env bid bv in - let nbc = { v with V.value = V.Borrow nbc } in - if insert = [] then (* No reborrows: do nothing special *) - nbc - else - (* There are reborrows: insert a shared loan *) - let insert = borrows_to_set insert in - let value = V.Loan (V.SharedLoan (insert, nbc)) in - let ty = v.V.ty in - { V.value; ty } - | _ -> super#visit_typed_value env v - - (** We reimplement {!visit_loan_content} (rather than one of the sub- - functions) on purpose: exhaustive matches are good for maintenance *) - method! visit_loan_content env lc = - match lc with - | V.SharedLoan (bids, sv) -> - (* Insert the reborrows *) - let bids = insert_reborrows bids in - (* Check if the contained value is a mutable borrow, in which - * case we might need to reborrow it by adding more borrow ids - * to the current set of borrows - by doing this small - * manipulation here, we accumulate the borrow ids in the same - * shared loan, right above the mutable borrow, and avoid - * stacking shared loans (note that doing this is not a problem - * from a soundness point of view, but it is a bit ugly...) *) - let bids = - match get_borrow_in_mut_borrow sv with - | None -> bids - | Some bid -> insert_reborrows_for_bid bids bid - in - (* Update and explore *) - super#visit_SharedLoan env bids sv - | V.MutLoan bid -> - (* Nothing special to do *) - super#visit_MutLoan env bid - - method! visit_aloan_content env lc = - match lc with - | V.ASharedLoan (bids, sv, av) -> - (* Insert the reborrows *) - let bids = insert_reborrows bids in - (* Similarly to the non-abstraction case: check if the shared - * value is a mutable borrow, to eventually insert more reborrows *) - (* Update and explore *) - let bids = - match get_borrow_in_mut_borrow sv with - | None -> bids - | Some bid -> insert_reborrows_for_bid bids bid - in - (* Update and explore *) - super#visit_ASharedLoan env bids sv av - | V.AIgnoredSharedLoan _ - | V.AMutLoan (_, _) - | V.AEndedMutLoan { given_back = _; child = _; given_back_meta = _ } - | V.AEndedSharedLoan (_, _) - | V.AIgnoredMutLoan (_, _) - | V.AEndedIgnoredMutLoan - { given_back = _; child = _; given_back_meta = _ } -> - (* Nothing particular to do *) - super#visit_aloan_content env lc - end - in - - (* Visit *) - let ctx = obj#visit_eval_ctx () ctx in - (* Check that there are no reborrows remaining *) - assert (!reborrows = []); - (* Return *) - ctx - -(** Auxiliary function to prepare reborrowing operations (used when - applying projectors). - - Returns two functions: - - a function to generate fresh re-borrow ids, and register the reborrows - - a function to apply the reborrows in a context - Those functions are of course stateful. - *) -let prepare_reborrows (config : C.config) (allow_reborrows : bool) : - (V.BorrowId.id -> V.BorrowId.id) * (C.eval_ctx -> C.eval_ctx) = - let reborrows : (V.BorrowId.id * V.BorrowId.id) list ref = ref [] in - (* The function to generate and register fresh reborrows *) - let fresh_reborrow (bid : V.BorrowId.id) : V.BorrowId.id = - if allow_reborrows then ( - let bid' = C.fresh_borrow_id () in - reborrows := (bid, bid') :: !reborrows; - bid') - else failwith "Unexpected reborrow" - in - (* The function to apply the reborrows in a context *) - let apply_registered_reborrows (ctx : C.eval_ctx) : C.eval_ctx = - match config.C.mode with - | C.ConcreteMode -> - assert (!reborrows = []); - ctx - | C.SymbolicMode -> - (* Apply the reborrows *) - apply_reborrows !reborrows ctx - in - (fresh_reborrow, apply_registered_reborrows) - -let apply_proj_borrows_on_input_value (config : C.config) (ctx : C.eval_ctx) - (regions : T.RegionId.Set.t) (ancestors_regions : T.RegionId.Set.t) - (v : V.typed_value) (ty : T.rty) : C.eval_ctx * V.typed_avalue = - let check_symbolic_no_ended = true in - let allow_reborrows = true in - (* Prepare the reborrows *) - let fresh_reborrow, apply_registered_reborrows = - prepare_reborrows config allow_reborrows - in - (* Apply the projector *) - let av = - apply_proj_borrows check_symbolic_no_ended ctx fresh_reborrow regions - ancestors_regions v ty - in - (* Apply the reborrows *) - let ctx = apply_registered_reborrows ctx in - (* Return *) - (ctx, av) diff --git a/src/InterpreterStatements.ml b/src/InterpreterStatements.ml deleted file mode 100644 index 4e61e683..00000000 --- a/src/InterpreterStatements.ml +++ /dev/null @@ -1,1370 +0,0 @@ -module T = Types -module V = Values -module E = Expressions -module C = Contexts -module Subst = Substitute -module A = LlbcAst -module L = Logging -open TypesUtils -open ValuesUtils -module Inv = Invariants -module S = SynthesizeSymbolic -open Errors -open Cps -open InterpreterUtils -open InterpreterProjectors -open InterpreterExpansion -open InterpreterPaths -open InterpreterExpressions - -(** The local logger *) -let log = L.statements_log - -(** Drop a value at a given place - TODO: factorize this with [assign_to_place] *) -let drop_value (config : C.config) (p : E.place) : cm_fun = - fun cf ctx -> - log#ldebug - (lazy - ("drop_value: place: " ^ place_to_string ctx p ^ "\n- Initial context:\n" - ^ eval_ctx_to_string ctx)); - (* Prepare the place (by ending the outer loans). - * Note that {!prepare_lplace} will use the [Write] access kind: - * it is ok, because when updating the value with {!Bottom} below, - * we will use the [Move] access *) - let end_borrows = false in - let prepare = prepare_lplace config end_borrows p in - (* Replace the value with {!Bottom} *) - let replace cf (v : V.typed_value) ctx = - (* Move the value at destination (that we will overwrite) to a dummy variable - * to preserve the borrows *) - let mv = read_place_unwrap config Write p ctx in - let ctx = C.ctx_push_dummy_var ctx mv in - (* Update the destination to ⊥ *) - let nv = { v with value = V.Bottom } in - let ctx = write_place_unwrap config Move p nv ctx in - log#ldebug - (lazy - ("drop_value: place: " ^ place_to_string ctx p ^ "\n- Final context:\n" - ^ eval_ctx_to_string ctx)); - cf ctx - in - (* Compose and apply *) - comp prepare replace cf ctx - -(** Push a dummy variable to the environment *) -let push_dummy_var (v : V.typed_value) : cm_fun = - fun cf ctx -> - let ctx = C.ctx_push_dummy_var ctx v in - cf ctx - -(** Pop a dummy variable from the environment *) -let pop_dummy_var (cf : V.typed_value -> m_fun) : m_fun = - fun ctx -> - let ctx, v = C.ctx_pop_dummy_var ctx in - cf v ctx - -(** Push an uninitialized variable to the environment *) -let push_uninitialized_var (var : A.var) : cm_fun = - fun cf ctx -> - let ctx = C.ctx_push_uninitialized_var ctx var in - cf ctx - -(** Push a list of uninitialized variables to the environment *) -let push_uninitialized_vars (vars : A.var list) : cm_fun = - fun cf ctx -> - let ctx = C.ctx_push_uninitialized_vars ctx vars in - cf ctx - -(** Push a variable to the environment *) -let push_var (var : A.var) (v : V.typed_value) : cm_fun = - fun cf ctx -> - let ctx = C.ctx_push_var ctx var v in - cf ctx - -(** Push a list of variables to the environment *) -let push_vars (vars : (A.var * V.typed_value) list) : cm_fun = - fun cf ctx -> - let ctx = C.ctx_push_vars ctx vars in - cf ctx - -(** Assign a value to a given place. - - Note that this function first pushes the value to assign in a dummy variable, - then prepares the destination (by ending borrows, etc.) before popping the - dummy variable and putting in its destination (after having checked that - preparing the destination didn't introduce ⊥). - *) -let assign_to_place (config : C.config) (rv : V.typed_value) (p : E.place) : - cm_fun = - fun cf ctx -> - log#ldebug - (lazy - ("assign_to_place:" ^ "\n- rv: " - ^ typed_value_to_string ctx rv - ^ "\n- p: " ^ place_to_string ctx p ^ "\n- Initial context:\n" - ^ eval_ctx_to_string ctx)); - (* Push the rvalue to a dummy variable, for bookkeeping *) - let cc = push_dummy_var rv in - (* Prepare the destination *) - let end_borrows = false in - let cc = comp cc (prepare_lplace config end_borrows p) in - (* Retrieve the rvalue from the dummy variable *) - let cc = comp cc (fun cf _lv -> pop_dummy_var cf) in - (* Update the destination *) - let move_dest cf (rv : V.typed_value) : m_fun = - fun ctx -> - (* Move the value at destination (that we will overwrite) to a dummy variable - * to preserve the borrows *) - let mv = read_place_unwrap config Write p ctx in - let ctx = C.ctx_push_dummy_var ctx mv in - (* Write to the destination *) - (* Checks - maybe the bookkeeping updated the rvalue and introduced bottoms *) - assert (not (bottom_in_value ctx.ended_regions rv)); - (* Update the destination *) - let ctx = write_place_unwrap config Write p rv ctx in - (* Debug *) - log#ldebug - (lazy - ("assign_to_place:" ^ "\n- rv: " - ^ typed_value_to_string ctx rv - ^ "\n- p: " ^ place_to_string ctx p ^ "\n- Final context:\n" - ^ eval_ctx_to_string ctx)); - (* Continue *) - cf ctx - in - (* Compose and apply *) - comp cc move_dest cf ctx - -(** Evaluate an assertion, when the scrutinee is not symbolic *) -let eval_assertion_concrete (config : C.config) (assertion : A.assertion) : - st_cm_fun = - fun cf ctx -> - (* There won't be any symbolic expansions: fully evaluate the operand *) - let eval_op = eval_operand config assertion.cond in - let eval_assert cf (v : V.typed_value) : m_fun = - fun ctx -> - match v.value with - | Concrete (Bool b) -> - (* Branch *) - if b = assertion.expected then cf Unit ctx else cf Panic ctx - | _ -> - raise - (Failure ("Expected a boolean, got: " ^ typed_value_to_string ctx v)) - in - (* Compose and apply *) - comp eval_op eval_assert cf ctx - -(** Evaluates an assertion. - - In the case the boolean under scrutinee is symbolic, we synthesize - a call to [assert ...] then continue in the success branch (and thus - expand the boolean to [true]). - *) -let eval_assertion (config : C.config) (assertion : A.assertion) : st_cm_fun = - fun cf ctx -> - (* Evaluate the operand *) - let eval_op = eval_operand config assertion.cond in - (* Evaluate the assertion *) - let eval_assert cf (v : V.typed_value) : m_fun = - fun ctx -> - assert (v.ty = T.Bool); - (* We make a choice here: we could completely decouple the concrete and - * symbolic executions here but choose not to. In the case where we - * know the concrete value of the boolean we test, we use this value - * even if we are in symbolic mode. Note that this case should be - * extremely rare... *) - match v.value with - | Concrete (Bool _) -> - (* Delegate to the concrete evaluation function *) - eval_assertion_concrete config assertion cf ctx - | Symbolic sv -> - assert (config.mode = C.SymbolicMode); - assert (sv.V.sv_ty = T.Bool); - (* Expand the symbolic value and call the proper continuation functions - * for the true and false cases - TODO: call an "assert" function instead *) - let cf_true : m_fun = fun ctx -> cf Unit ctx in - let cf_false : m_fun = fun ctx -> cf Panic ctx in - let expand = - expand_symbolic_bool config sv - (S.mk_opt_place_from_op assertion.cond ctx) - cf_true cf_false - in - expand ctx - | _ -> - raise - (Failure ("Expected a boolean, got: " ^ typed_value_to_string ctx v)) - in - (* Compose and apply *) - comp eval_op eval_assert cf ctx - -(** Updates the discriminant of a value at a given place. - - There are two situations: - - either the discriminant is already the proper one (in which case we - don't do anything) - - or it is not the proper one (because the variant is not the proper - one, or the value is actually {!V.Bottom} - this happens when - initializing ADT values), in which case we replace the value with - a variant with all its fields set to {!V.Bottom}. - For instance, something like: [Cons Bottom Bottom]. - *) -let set_discriminant (config : C.config) (p : E.place) - (variant_id : T.VariantId.id) : st_cm_fun = - fun cf ctx -> - log#ldebug - (lazy - ("set_discriminant:" ^ "\n- p: " ^ place_to_string ctx p - ^ "\n- variant id: " - ^ T.VariantId.to_string variant_id - ^ "\n- initial context:\n" ^ eval_ctx_to_string ctx)); - (* Access the value *) - let access = Write in - let cc = update_ctx_along_read_place config access p in - let end_borrows = false in - let cc = comp cc (prepare_lplace config end_borrows p) in - (* Update the value *) - let update_value cf (v : V.typed_value) : m_fun = - fun ctx -> - match (v.V.ty, v.V.value) with - | ( T.Adt (((T.AdtId _ | T.Assumed T.Option) as type_id), regions, types), - V.Adt av ) -> ( - (* There are two situations: - - either the discriminant is already the proper one (in which case we - don't do anything) - - or it is not the proper one, in which case we replace the value with - a variant with all its fields set to {!Bottom} - *) - match av.variant_id with - | None -> raise (Failure "Found a struct value while expected an enum") - | Some variant_id' -> - if variant_id' = variant_id then (* Nothing to do *) - cf Unit ctx - else - (* Replace the value *) - let bottom_v = - match type_id with - | T.AdtId def_id -> - compute_expanded_bottom_adt_value - ctx.type_context.type_decls def_id (Some variant_id) - regions types - | T.Assumed T.Option -> - assert (regions = []); - compute_expanded_bottom_option_value variant_id - (Collections.List.to_cons_nil types) - | _ -> raise (Failure "Unreachable") - in - assign_to_place config bottom_v p (cf Unit) ctx) - | ( T.Adt (((T.AdtId _ | T.Assumed T.Option) as type_id), regions, types), - V.Bottom ) -> - let bottom_v = - match type_id with - | T.AdtId def_id -> - compute_expanded_bottom_adt_value ctx.type_context.type_decls - def_id (Some variant_id) regions types - | T.Assumed T.Option -> - assert (regions = []); - compute_expanded_bottom_option_value variant_id - (Collections.List.to_cons_nil types) - | _ -> raise (Failure "Unreachable") - in - assign_to_place config bottom_v p (cf Unit) ctx - | _, V.Symbolic _ -> - assert (config.mode = SymbolicMode); - (* This is a bit annoying: in theory we should expand the symbolic value - * then set the discriminant, because in the case the discriminant is - * exactly the one we set, the fields are left untouched, and in the - * other cases they are set to Bottom. - * For now, we forbid setting the discriminant of a symbolic value: - * setting a discriminant should only be used to initialize a value, - * or reset an already initialized value, really. *) - raise (Failure "Unexpected value") - | _, (V.Adt _ | V.Bottom) -> raise (Failure "Inconsistent state") - | _, (V.Concrete _ | V.Borrow _ | V.Loan _) -> - raise (Failure "Unexpected value") - in - (* Compose and apply *) - comp cc update_value cf ctx - -(** Push a frame delimiter in the context's environment *) -let ctx_push_frame (ctx : C.eval_ctx) : C.eval_ctx = - { ctx with env = Frame :: ctx.env } - -(** Push a frame delimiter in the context's environment *) -let push_frame : cm_fun = fun cf ctx -> cf (ctx_push_frame ctx) - -(** Small helper: compute the type of the return value for a specific - instantiation of a non-local function. - *) -let get_non_local_function_return_type (fid : A.assumed_fun_id) - (region_params : T.erased_region list) (type_params : T.ety list) : T.ety = - (* [Box::free] has a special treatment *) - match (fid, region_params, type_params) with - | A.BoxFree, [], [ _ ] -> mk_unit_ty - | _ -> - (* Retrieve the function's signature *) - let sg = Assumed.get_assumed_sig fid in - (* Instantiate the return type *) - let tsubst = - Subst.make_type_subst - (List.map (fun v -> v.T.index) sg.type_params) - type_params - in - Subst.erase_regions_substitute_types tsubst sg.output - -let move_return_value (config : C.config) (cf : V.typed_value -> m_fun) : m_fun - = - fun ctx -> - let ret_vid = V.VarId.zero in - let cc = eval_operand config (E.Move (mk_place_from_var_id ret_vid)) in - cc cf ctx - -(** Pop the current frame. - - Drop all the local variables but the return variable, move the return - value out of the return variable, remove all the local variables (but not the - abstractions!) from the context, remove the {!C.Frame} indicator delimiting the - current frame and handle the return value to the continuation. - - TODO: rename (remove the "ctx_") - *) -let ctx_pop_frame (config : C.config) (cf : V.typed_value -> m_fun) : m_fun = - fun ctx -> - (* Debug *) - log#ldebug (lazy ("ctx_pop_frame:\n" ^ eval_ctx_to_string ctx)); - - (* List the local variables, but the return variable *) - let ret_vid = V.VarId.zero in - let rec list_locals env = - match env with - | [] -> raise (Failure "Inconsistent environment") - | C.Abs _ :: env -> list_locals env - | C.Var (None, _) :: env -> list_locals env - | C.Var (Some var, _) :: env -> - let locals = list_locals env in - if var.index <> ret_vid then var.index :: locals else locals - | C.Frame :: _ -> [] - in - let locals : V.VarId.id list = list_locals ctx.env in - (* Debug *) - log#ldebug - (lazy - ("ctx_pop_frame: locals in which to drop the outer loans: [" - ^ String.concat "," (List.map V.VarId.to_string locals) - ^ "]")); - - (* Move the return value out of the return variable *) - let cc = move_return_value config in - (* Sanity check *) - let cc = - comp_check_value cc (fun ret_value ctx -> - assert (not (bottom_in_value ctx.ended_regions ret_value))) - in - - (* Drop the outer *loans* we find in the local variables *) - let cf_drop_loans_in_locals cf (ret_value : V.typed_value) : m_fun = - (* Drop the loans *) - let end_borrows = false in - let locals = List.rev locals in - let cf_drop = - List.fold_left - (fun cf lid -> - drop_outer_borrows_loans_at_lplace config end_borrows - (mk_place_from_var_id lid) cf) - (cf ret_value) locals - in - (* Apply *) - cf_drop - in - let cc = comp cc cf_drop_loans_in_locals in - (* Debug *) - let cc = - comp_check_value cc (fun _ ctx -> - log#ldebug - (lazy - ("ctx_pop_frame: after dropping outer loans in local variables:\n" - ^ eval_ctx_to_string ctx))) - in - - (* Pop the frame - we remove the [Frame] delimiter, and reintroduce all - * the local variables (which may still contain borrow permissions - but - * no outer loans) as dummy variables in the caller frame *) - let rec pop env = - match env with - | [] -> raise (Failure "Inconsistent environment") - | C.Abs abs :: env -> C.Abs abs :: pop env - | C.Var (_, v) :: env -> C.Var (None, v) :: pop env - | C.Frame :: env -> (* Stop here *) env - in - let cf_pop cf (ret_value : V.typed_value) : m_fun = - fun ctx -> - let env = pop ctx.env in - let ctx = { ctx with env } in - cf ret_value ctx - in - (* Compose and apply *) - comp cc cf_pop cf ctx - -(** Pop the current frame and assign the returned value to its destination. *) -let pop_frame_assign (config : C.config) (dest : E.place) : cm_fun = - let cf_pop = ctx_pop_frame config in - let cf_assign cf ret_value : m_fun = - assign_to_place config ret_value dest cf - in - comp cf_pop cf_assign - -(** Auxiliary function - see [eval_non_local_function_call] *) -let eval_replace_concrete (_config : C.config) - (_region_params : T.erased_region list) (_type_params : T.ety list) : cm_fun - = - fun _cf _ctx -> raise Unimplemented - -(** Auxiliary function - see [eval_non_local_function_call] *) -let eval_box_new_concrete (config : C.config) - (region_params : T.erased_region list) (type_params : T.ety list) : cm_fun = - fun cf ctx -> - (* Check and retrieve the arguments *) - match (region_params, type_params, ctx.env) with - | ( [], - [ boxed_ty ], - Var (Some input_var, input_value) :: Var (_ret_var, _) :: C.Frame :: _ ) - -> - (* Required type checking *) - assert (input_value.V.ty = boxed_ty); - - (* Move the input value *) - let cf_move = - eval_operand config (E.Move (mk_place_from_var_id input_var.C.index)) - in - - (* Create the new box *) - let cf_create cf (moved_input_value : V.typed_value) : m_fun = - (* Create the box value *) - let box_ty = T.Adt (T.Assumed T.Box, [], [ boxed_ty ]) in - let box_v = - V.Adt { variant_id = None; field_values = [ moved_input_value ] } - in - let box_v = mk_typed_value box_ty box_v in - - (* Move this value to the return variable *) - let dest = mk_place_from_var_id V.VarId.zero in - let cf_assign = assign_to_place config box_v dest in - - (* Continue *) - cf_assign cf - in - - (* Compose and apply *) - comp cf_move cf_create cf ctx - | _ -> raise (Failure "Inconsistent state") - -(** Auxiliary function which factorizes code to evaluate [std::Deref::deref] - and [std::DerefMut::deref_mut] - see [eval_non_local_function_call] *) -let eval_box_deref_mut_or_shared_concrete (config : C.config) - (region_params : T.erased_region list) (type_params : T.ety list) - (is_mut : bool) : cm_fun = - fun cf ctx -> - (* Check the arguments *) - match (region_params, type_params, ctx.env) with - | ( [], - [ boxed_ty ], - Var (Some input_var, input_value) :: Var (_ret_var, _) :: C.Frame :: _ ) - -> - (* Required type checking. We must have: - - input_value.ty == & (mut) Box<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/src/InterpreterUtils.ml b/src/InterpreterUtils.ml deleted file mode 100644 index e6033e9e..00000000 --- a/src/InterpreterUtils.ml +++ /dev/null @@ -1,245 +0,0 @@ -module T = Types -module V = Values -module E = Expressions -module C = Contexts -module Subst = Substitute -module A = LlbcAst -module L = Logging -open Utils -open TypesUtils -module PA = Print.EvalCtxLlbcAst - -(** Some utilities *) - -let eval_ctx_to_string = Print.Contexts.eval_ctx_to_string -let ety_to_string = PA.ety_to_string -let rty_to_string = PA.rty_to_string -let symbolic_value_to_string = PA.symbolic_value_to_string -let borrow_content_to_string = PA.borrow_content_to_string -let loan_content_to_string = PA.loan_content_to_string -let aborrow_content_to_string = PA.aborrow_content_to_string -let aloan_content_to_string = PA.aloan_content_to_string -let aproj_to_string = PA.aproj_to_string -let typed_value_to_string = PA.typed_value_to_string -let typed_avalue_to_string = PA.typed_avalue_to_string -let place_to_string = PA.place_to_string -let operand_to_string = PA.operand_to_string -let statement_to_string ctx = PA.statement_to_string ctx "" " " -let statement_to_string_with_tab ctx = PA.statement_to_string ctx " " " " - -let same_symbolic_id (sv0 : V.symbolic_value) (sv1 : V.symbolic_value) : bool = - sv0.V.sv_id = sv1.V.sv_id - -let mk_var (index : V.VarId.id) (name : string option) (var_ty : T.ety) : A.var - = - { A.index; name; var_ty } - -(** Small helper - TODO: move *) -let mk_place_from_var_id (var_id : V.VarId.id) : E.place = - { var_id; projection = [] } - -(** Create a fresh symbolic value *) -let mk_fresh_symbolic_value (sv_kind : V.sv_kind) (ty : T.rty) : - V.symbolic_value = - let sv_id = C.fresh_symbolic_value_id () in - let svalue = { V.sv_kind; V.sv_id; V.sv_ty = ty } in - svalue - -(** Create a fresh symbolic value *) -let mk_fresh_symbolic_typed_value (sv_kind : V.sv_kind) (rty : T.rty) : - V.typed_value = - let ty = Subst.erase_regions rty in - (* Generate the fresh a symbolic value *) - let value = mk_fresh_symbolic_value sv_kind rty in - let value = V.Symbolic value in - { V.value; V.ty } - -(** Create a typed value from a symbolic value. *) -let mk_typed_value_from_symbolic_value (svalue : V.symbolic_value) : - V.typed_value = - let av = V.Symbolic svalue in - let av : V.typed_value = - { V.value = av; V.ty = Subst.erase_regions svalue.V.sv_ty } - in - av - -(** Create a loans projector value from a symbolic value. - - Checks if the projector will actually project some regions. If not, - returns {!V.AIgnored} ([_]). - - TODO: update to handle 'static - *) -let mk_aproj_loans_value_from_symbolic_value (regions : T.RegionId.Set.t) - (svalue : V.symbolic_value) : V.typed_avalue = - if ty_has_regions_in_set regions svalue.sv_ty then - let av = V.ASymbolic (V.AProjLoans (svalue, [])) in - let av : V.typed_avalue = { V.value = av; V.ty = svalue.V.sv_ty } in - av - else { V.value = V.AIgnored; ty = svalue.V.sv_ty } - -(** Create a borrows projector from a symbolic value *) -let mk_aproj_borrows_from_symbolic_value (proj_regions : T.RegionId.Set.t) - (svalue : V.symbolic_value) (proj_ty : T.rty) : V.aproj = - if ty_has_regions_in_set proj_regions proj_ty then - V.AProjBorrows (svalue, proj_ty) - else V.AIgnoredProjBorrows - -(** TODO: move *) -let borrow_is_asb (bid : V.BorrowId.id) (asb : V.abstract_shared_borrow) : bool - = - match asb with - | V.AsbBorrow bid' -> bid' = bid - | V.AsbProjReborrows _ -> false - -(** TODO: move *) -let borrow_in_asb (bid : V.BorrowId.id) (asb : V.abstract_shared_borrows) : bool - = - List.exists (borrow_is_asb bid) asb - -(** TODO: move *) -let remove_borrow_from_asb (bid : V.BorrowId.id) - (asb : V.abstract_shared_borrows) : V.abstract_shared_borrows = - let removed = ref 0 in - let asb = - List.filter - (fun asb -> - if not (borrow_is_asb bid asb) then true - else ( - removed := !removed + 1; - false)) - asb - in - assert (!removed = 1); - asb - -(** We sometimes need to return a value whose type may vary depending on - whether we find it in a "concrete" value or an abstraction (ex.: loan - contents when we perform environment lookups by using borrow ids) *) -type ('a, 'b) concrete_or_abs = Concrete of 'a | Abstract of 'b - -(** Generic loan content: concrete or abstract *) -type g_loan_content = (V.loan_content, V.aloan_content) concrete_or_abs - -(** Generic borrow content: concrete or abstract *) -type g_borrow_content = (V.borrow_content, V.aborrow_content) concrete_or_abs - -type abs_or_var_id = AbsId of V.AbstractionId.id | VarId of V.VarId.id option - -(** Utility exception *) -exception FoundBorrowContent of V.borrow_content - -(** Utility exception *) -exception FoundLoanContent of V.loan_content - -(** Utility exception *) -exception FoundABorrowContent of V.aborrow_content - -(** Utility exception *) -exception FoundGBorrowContent of g_borrow_content - -(** Utility exception *) -exception FoundGLoanContent of g_loan_content - -(** Utility exception *) -exception FoundAProjBorrows of V.symbolic_value * T.rty - -let symbolic_value_id_in_ctx (sv_id : V.SymbolicValueId.id) (ctx : C.eval_ctx) : - bool = - let obj = - object - inherit [_] C.iter_eval_ctx as super - - method! visit_Symbolic _ sv = - if sv.V.sv_id = sv_id then raise Found else () - - method! visit_aproj env aproj = - (match aproj with - | AProjLoans (sv, _) | AProjBorrows (sv, _) -> - if sv.V.sv_id = sv_id then raise Found else () - | AEndedProjLoans _ | AEndedProjBorrows _ | AIgnoredProjBorrows -> ()); - super#visit_aproj env aproj - - method! visit_abstract_shared_borrows _ asb = - let visit (asb : V.abstract_shared_borrow) : unit = - match asb with - | V.AsbBorrow _ -> () - | V.AsbProjReborrows (sv, _) -> - if sv.V.sv_id = sv_id then raise Found else () - in - List.iter visit asb - end - in - (* We use exceptions *) - try - obj#visit_eval_ctx () ctx; - false - with Found -> true - -(** Check that a symbolic value doesn't contain ended regions. - - Note that we don't check that the set of ended regions is empty: we - check that the set of ended regions doesn't intersect the set of - regions used in the type (this is more general). -*) -let symbolic_value_has_ended_regions (ended_regions : T.RegionId.Set.t) - (s : V.symbolic_value) : bool = - let regions = rty_regions s.V.sv_ty in - not (T.RegionId.Set.disjoint regions ended_regions) - -(** Check if a {!type:V.value} contains [⊥]. - - Note that this function is very general: it also checks wether - symbolic values contain already ended regions. - *) -let bottom_in_value (ended_regions : T.RegionId.Set.t) (v : V.typed_value) : - bool = - let obj = - object - inherit [_] V.iter_typed_value - method! visit_Bottom _ = raise Found - - method! visit_symbolic_value _ s = - if symbolic_value_has_ended_regions ended_regions s then raise Found - else () - end - in - (* We use exceptions *) - try - obj#visit_typed_value () v; - false - with Found -> true - -let value_has_ret_symbolic_value_with_borrow_under_mut (ctx : C.eval_ctx) - (v : V.typed_value) : bool = - let obj = - object - inherit [_] V.iter_typed_value - - method! visit_symbolic_value _ s = - match s.sv_kind with - | V.FunCallRet -> - if ty_has_borrow_under_mut ctx.type_context.type_infos s.sv_ty then - raise Found - else () - | V.SynthInput | V.SynthInputGivenBack | V.FunCallGivenBack - | V.SynthRetGivenBack -> - () - | V.Global -> () - end - in - (* We use exceptions *) - try - obj#visit_typed_value () v; - false - with Found -> true - -(** Return the place used in an rvalue, if that makes sense. - This is used to compute meta-data, to find pretty names. - *) -let rvalue_get_place (rv : E.rvalue) : E.place option = - match rv with - | Use (Copy p | Move p) -> Some p - | Use (Constant _) -> None - | Ref (p, _) -> Some p - | UnaryOp _ | BinaryOp _ | Discriminant _ | Aggregate _ -> None diff --git a/src/Invariants.ml b/src/Invariants.ml deleted file mode 100644 index 4a3364a6..00000000 --- a/src/Invariants.ml +++ /dev/null @@ -1,794 +0,0 @@ -(* The following module defines functions to check that some invariants - * are always maintained by evaluation contexts *) - -module T = Types -module V = Values -module E = Expressions -module C = Contexts -module Subst = Substitute -module A = LlbcAst -module L = Logging -open Cps -open TypesUtils -open InterpreterUtils -open InterpreterBorrowsCore - -(** The local logger *) -let log = L.invariants_log - -type borrow_info = { - loan_kind : T.ref_kind; - loan_in_abs : bool; - (* true if the loan was found in an abstraction *) - loan_ids : V.BorrowId.Set.t; - borrow_ids : V.BorrowId.Set.t; -} -[@@deriving show] - -type outer_borrow_info = { - outer_borrow : bool; - (* true if the value is borrowed *) - outer_shared : bool; (* true if the value is borrowed as shared *) -} - -let set_outer_mut (info : outer_borrow_info) : outer_borrow_info = - { info with outer_borrow = true } - -let set_outer_shared (_info : outer_borrow_info) : outer_borrow_info = - { outer_borrow = true; outer_shared = true } - -let ids_reprs_to_string (indent : string) - (reprs : V.BorrowId.id V.BorrowId.Map.t) : string = - V.BorrowId.Map.to_string (Some indent) V.BorrowId.to_string reprs - -let borrows_infos_to_string (indent : string) - (infos : borrow_info V.BorrowId.Map.t) : string = - V.BorrowId.Map.to_string (Some indent) show_borrow_info infos - -type borrow_kind = Mut | Shared | Inactivated - -(** Check that: - - loans and borrows are correctly related - - a two-phase borrow can't point to a value inside an abstraction - *) -let check_loans_borrows_relation_invariant (ctx : C.eval_ctx) : unit = - (* Link all the borrow ids to a representant - necessary because of shared - * borrows/loans *) - let ids_reprs : V.BorrowId.id V.BorrowId.Map.t ref = - ref V.BorrowId.Map.empty - in - (* Link all the id representants to a borrow information *) - let borrows_infos : borrow_info V.BorrowId.Map.t ref = - ref V.BorrowId.Map.empty - in - let context_to_string () : string = - eval_ctx_to_string ctx ^ "- representants:\n" - ^ ids_reprs_to_string " " !ids_reprs - ^ "\n- info:\n" - ^ borrows_infos_to_string " " !borrows_infos - in - (* Ignored loans - when we find an ignored loan while building the borrows_infos - * map, we register it in this list; once the borrows_infos map is completely - * built, we check that all the borrow ids of the ignored loans are in this - * map *) - let ignored_loans : (T.ref_kind * V.BorrowId.id) list ref = ref [] in - - (* first, register all the loans *) - (* Some utilities to register the loans *) - let register_ignored_loan (rkind : T.ref_kind) (bid : V.BorrowId.id) : unit = - ignored_loans := (rkind, bid) :: !ignored_loans - in - - let register_shared_loan (loan_in_abs : bool) (bids : V.BorrowId.Set.t) : unit - = - let reprs = !ids_reprs in - let infos = !borrows_infos in - (* Use the first borrow id as representant *) - let repr_bid = V.BorrowId.Set.min_elt bids in - assert (not (V.BorrowId.Map.mem repr_bid infos)); - (* Insert the mappings to the representant *) - let reprs = - V.BorrowId.Set.fold - (fun bid reprs -> - assert (not (V.BorrowId.Map.mem bid reprs)); - V.BorrowId.Map.add bid repr_bid reprs) - bids reprs - in - (* Insert the loan info *) - let info = - { - loan_kind = T.Shared; - loan_in_abs; - loan_ids = bids; - borrow_ids = V.BorrowId.Set.empty; - } - in - let infos = V.BorrowId.Map.add repr_bid info infos in - (* Update *) - ids_reprs := reprs; - borrows_infos := infos - in - - let register_mut_loan (loan_in_abs : bool) (bid : V.BorrowId.id) : unit = - let reprs = !ids_reprs in - let infos = !borrows_infos in - (* Sanity checks *) - assert (not (V.BorrowId.Map.mem bid reprs)); - assert (not (V.BorrowId.Map.mem bid infos)); - (* Add the mapping for the representant *) - let reprs = V.BorrowId.Map.add bid bid reprs in - (* Add the mapping for the loan info *) - let info = - { - loan_kind = T.Mut; - loan_in_abs; - loan_ids = V.BorrowId.Set.singleton bid; - borrow_ids = V.BorrowId.Set.empty; - } - in - let infos = V.BorrowId.Map.add bid info infos in - (* Update *) - ids_reprs := reprs; - borrows_infos := infos - in - - let loans_visitor = - object - inherit [_] C.iter_eval_ctx as super - - method! visit_Var _ binder v = - let inside_abs = false in - super#visit_Var inside_abs binder v - - method! visit_Abs _ abs = - let inside_abs = true in - super#visit_Abs inside_abs abs - - method! visit_loan_content inside_abs lc = - (* Register the loan *) - let _ = - match lc with - | V.SharedLoan (bids, _) -> register_shared_loan inside_abs bids - | V.MutLoan bid -> register_mut_loan inside_abs bid - in - (* Continue exploring *) - super#visit_loan_content inside_abs lc - - method! visit_aloan_content inside_abs lc = - let _ = - match lc with - | V.AMutLoan (bid, _) -> register_mut_loan inside_abs bid - | V.ASharedLoan (bids, _, _) -> register_shared_loan inside_abs bids - | V.AIgnoredMutLoan (bid, _) -> register_ignored_loan T.Mut bid - | V.AIgnoredSharedLoan _ - | V.AEndedMutLoan { given_back = _; child = _; given_back_meta = _ } - | V.AEndedSharedLoan (_, _) - | V.AEndedIgnoredMutLoan - { given_back = _; child = _; given_back_meta = _ } -> - (* Do nothing *) - () - in - (* Continue exploring *) - super#visit_aloan_content inside_abs lc - end - in - - (* Visit *) - let inside_abs = false in - loans_visitor#visit_eval_ctx inside_abs ctx; - - (* Then, register all the borrows *) - (* Some utilities to register the borrows *) - let find_info (bid : V.BorrowId.id) : borrow_info = - (* Find the representant *) - match V.BorrowId.Map.find_opt bid !ids_reprs with - | Some repr_bid -> - (* Lookup the info *) - V.BorrowId.Map.find repr_bid !borrows_infos - | None -> - let err = - "find_info: could not find the representant of borrow " - ^ V.BorrowId.to_string bid ^ ":\nContext:\n" ^ context_to_string () - in - log#serror err; - failwith err - in - - let update_info (bid : V.BorrowId.id) (info : borrow_info) : unit = - (* Find the representant *) - let repr_bid = V.BorrowId.Map.find bid !ids_reprs in - (* Update the info *) - let infos = - V.BorrowId.Map.update repr_bid - (fun x -> - match x with Some _ -> Some info | None -> failwith "Unreachable") - !borrows_infos - in - borrows_infos := infos - in - - let register_ignored_borrow = register_ignored_loan in - - let register_borrow (kind : borrow_kind) (bid : V.BorrowId.id) : unit = - (* Lookup the info *) - let info = find_info bid in - (* Check that the borrow kind is consistent *) - (match (info.loan_kind, kind) with - | T.Shared, (Shared | Inactivated) | T.Mut, Mut -> () - | _ -> failwith "Invariant not satisfied"); - (* An inactivated borrow can't point to a value inside an abstraction *) - assert (kind <> Inactivated || not info.loan_in_abs); - (* Insert the borrow id *) - let borrow_ids = info.borrow_ids in - assert (not (V.BorrowId.Set.mem bid borrow_ids)); - let info = { info with borrow_ids = V.BorrowId.Set.add bid borrow_ids } in - (* Update the info in the map *) - update_info bid info - in - - let borrows_visitor = - object - inherit [_] C.iter_eval_ctx as super - - method! visit_abstract_shared_borrows _ asb = - let visit asb = - match asb with - | V.AsbBorrow bid -> register_borrow Shared bid - | V.AsbProjReborrows _ -> () - in - List.iter visit asb - - method! visit_borrow_content env bc = - (* Register the loan *) - let _ = - match bc with - | V.SharedBorrow (_, bid) -> register_borrow Shared bid - | V.MutBorrow (bid, _) -> register_borrow Mut bid - | V.InactivatedMutBorrow (_, bid) -> register_borrow Inactivated bid - in - (* Continue exploring *) - super#visit_borrow_content env bc - - method! visit_aborrow_content env bc = - let _ = - match bc with - | V.AMutBorrow (_, bid, _) -> register_borrow Mut bid - | V.ASharedBorrow bid -> register_borrow Shared bid - | V.AIgnoredMutBorrow (Some bid, _) -> register_ignored_borrow Mut bid - | V.AIgnoredMutBorrow (None, _) - | V.AEndedMutBorrow _ | V.AEndedIgnoredMutBorrow _ - | V.AEndedSharedBorrow | V.AProjSharedBorrow _ -> - (* Do nothing *) - () - in - (* Continue exploring *) - super#visit_aborrow_content env bc - end - in - - (* Visit *) - borrows_visitor#visit_eval_ctx () ctx; - - (* Debugging *) - log#ldebug - (lazy ("\nAbout to check context invariant:\n" ^ context_to_string ())); - - (* Finally, check that everything is consistant *) - (* First, check all the ignored loans are present at the proper place *) - List.iter - (fun (rkind, bid) -> - let info = find_info bid in - assert (info.loan_kind = rkind)) - !ignored_loans; - - (* Then, check the borrow infos *) - V.BorrowId.Map.iter - (fun _ info -> - (* Note that we can't directly compare the sets - I guess they are - * different depending on the order in which we add the elements... *) - assert ( - V.BorrowId.Set.elements info.loan_ids - = V.BorrowId.Set.elements info.borrow_ids); - match info.loan_kind with - | T.Mut -> assert (V.BorrowId.Set.cardinal info.loan_ids = 1) - | T.Shared -> ()) - !borrows_infos - -(** Check that: - - borrows/loans can't contain ⊥ or inactivated mut borrows - - shared loans can't contain mutable loans - *) -let check_borrowed_values_invariant (config : C.config) (ctx : C.eval_ctx) : - unit = - let visitor = - object - inherit [_] C.iter_eval_ctx as super - - method! visit_Bottom info = - (* No ⊥ inside borrowed values *) - assert (config.C.allow_bottom_below_borrow || not info.outer_borrow) - - method! visit_ABottom _info = - (* ⊥ inside an abstraction is not the same as in a regular value *) - () - - method! visit_loan_content info lc = - (* Update the info *) - let info = - match lc with - | V.SharedLoan (_, _) -> set_outer_shared info - | V.MutLoan _ -> - (* No mutable loan inside a shared loan *) - assert (not info.outer_shared); - set_outer_mut info - in - (* Continue exploring *) - super#visit_loan_content info lc - - method! visit_borrow_content info bc = - (* Update the info *) - let info = - match bc with - | V.SharedBorrow _ -> set_outer_shared info - | V.InactivatedMutBorrow _ -> - assert (not info.outer_borrow); - set_outer_shared info - | V.MutBorrow (_, _) -> set_outer_mut info - in - (* Continue exploring *) - super#visit_borrow_content info bc - - method! visit_aloan_content info lc = - (* Update the info *) - let info = - match lc with - | V.AMutLoan (_, _) -> set_outer_mut info - | V.ASharedLoan (_, _, _) -> set_outer_shared info - | V.AEndedMutLoan { given_back = _; child = _; given_back_meta = _ } - -> - set_outer_mut info - | V.AEndedSharedLoan (_, _) -> set_outer_shared info - | V.AIgnoredMutLoan (_, _) -> set_outer_mut info - | V.AEndedIgnoredMutLoan - { given_back = _; child = _; given_back_meta = _ } -> - set_outer_mut info - | V.AIgnoredSharedLoan _ -> set_outer_shared info - in - (* Continue exploring *) - super#visit_aloan_content info lc - - method! visit_aborrow_content info bc = - (* Update the info *) - let info = - match bc with - | V.AMutBorrow (_, _, _) -> set_outer_mut info - | V.ASharedBorrow _ | V.AEndedSharedBorrow -> set_outer_shared info - | V.AIgnoredMutBorrow _ | V.AEndedMutBorrow _ - | V.AEndedIgnoredMutBorrow _ -> - set_outer_mut info - | V.AProjSharedBorrow _ -> set_outer_shared info - in - (* Continue exploring *) - super#visit_aborrow_content info bc - end - in - - (* Explore *) - let info = { outer_borrow = false; outer_shared = false } in - visitor#visit_eval_ctx info ctx - -let check_constant_value_type (cv : V.constant_value) (ty : T.ety) : unit = - match (cv, ty) with - | V.Scalar sv, T.Integer int_ty -> assert (sv.int_ty = int_ty) - | V.Bool _, T.Bool | V.Char _, T.Char | V.String _, T.Str -> () - | _ -> failwith "Erroneous typing" - -let check_typing_invariant (ctx : C.eval_ctx) : unit = - (* TODO: the type of aloans doens't make sense: they have a type - * of the shape [& (mut) T] where they should have type [T]... - * This messes a bit the type invariant checks when checking the - * children. In order to isolate the problem (for future modifications) - * we introduce function, so that we can easily spot all the involved - * places. - * *) - let aloan_get_expected_child_type (ty : 'r T.ty) : 'r T.ty = - let _, ty, _ = ty_get_ref ty in - ty - in - - let visitor = - object - inherit [_] C.iter_eval_ctx as super - method! visit_abs _ abs = super#visit_abs (Some abs) abs - - method! visit_typed_value info tv = - (* Check the current pair (value, type) *) - (match (tv.V.value, tv.V.ty) with - | V.Concrete cv, ty -> check_constant_value_type cv ty - (* ADT case *) - | V.Adt av, T.Adt (T.AdtId def_id, regions, tys) -> - (* Retrieve the definition to check the variant id, the number of - * parameters, etc. *) - let def = C.ctx_lookup_type_decl ctx def_id in - (* Check the number of parameters *) - assert (List.length regions = List.length def.region_params); - assert (List.length tys = List.length def.type_params); - (* Check that the variant id is consistent *) - (match (av.V.variant_id, def.T.kind) with - | Some variant_id, T.Enum variants -> - assert (T.VariantId.to_int variant_id < List.length variants) - | None, T.Struct _ -> () - | _ -> failwith "Erroneous typing"); - (* Check that the field types are correct *) - let field_types = - Subst.type_decl_get_instantiated_field_etypes def av.V.variant_id - tys - in - let fields_with_types = - List.combine av.V.field_values field_types - in - List.iter - (fun ((v, ty) : V.typed_value * T.ety) -> assert (v.V.ty = ty)) - fields_with_types - (* Tuple case *) - | V.Adt av, T.Adt (T.Tuple, regions, tys) -> - assert (regions = []); - assert (av.V.variant_id = None); - (* Check that the fields have the proper values - and check that there - * are as many fields as field types at the same time *) - let fields_with_types = List.combine av.V.field_values tys in - List.iter - (fun ((v, ty) : V.typed_value * T.ety) -> assert (v.V.ty = ty)) - fields_with_types - (* Assumed type case *) - | V.Adt av, T.Adt (T.Assumed aty_id, regions, tys) -> ( - assert (av.V.variant_id = None || aty_id = T.Option); - match (aty_id, av.V.field_values, regions, tys) with - (* Box *) - | T.Box, [ inner_value ], [], [ inner_ty ] - | T.Option, [ inner_value ], [], [ inner_ty ] -> - assert (inner_value.V.ty = inner_ty) - | T.Option, _, [], [ _ ] -> - (* Option::None: nothing to check *) - () - | T.Vec, fvs, [], [ vec_ty ] -> - List.iter - (fun (v : V.typed_value) -> assert (v.ty = vec_ty)) - fvs - | _ -> failwith "Erroneous type") - | V.Bottom, _ -> (* Nothing to check *) () - | V.Borrow bc, T.Ref (_, ref_ty, rkind) -> ( - match (bc, rkind) with - | V.SharedBorrow (_, bid), T.Shared - | V.InactivatedMutBorrow (_, bid), T.Mut -> ( - (* Lookup the borrowed value to check it has the proper type *) - let _, glc = lookup_loan ek_all bid ctx in - match glc with - | Concrete (V.SharedLoan (_, sv)) - | Abstract (V.ASharedLoan (_, sv, _)) -> - assert (sv.V.ty = ref_ty) - | _ -> failwith "Inconsistent context") - | V.MutBorrow (_, bv), T.Mut -> - assert ( - (* Check that the borrowed value has the proper type *) - bv.V.ty = ref_ty) - | _ -> failwith "Erroneous typing") - | V.Loan lc, ty -> ( - match lc with - | V.SharedLoan (_, sv) -> assert (sv.V.ty = ty) - | V.MutLoan bid -> ( - (* Lookup the borrowed value to check it has the proper type *) - let glc = lookup_borrow ek_all bid ctx in - match glc with - | Concrete (V.MutBorrow (_, bv)) -> assert (bv.V.ty = ty) - | Abstract (V.AMutBorrow (_, _, sv)) -> - assert (Subst.erase_regions sv.V.ty = ty) - | _ -> failwith "Inconsistent context")) - | V.Symbolic sv, ty -> - let ty' = Subst.erase_regions sv.V.sv_ty in - assert (ty' = ty) - | _ -> failwith "Erroneous typing"); - (* Continue exploring to inspect the subterms *) - super#visit_typed_value info tv - - (* TODO: there is a lot of duplication with {!visit_typed_value} - * which is quite annoying. There might be a way of factorizing - * that by factorizing the definitions of value and avalue, but - * the generation of visitors then doesn't work properly (TODO: - * report that). Still, it is actually not that problematic - * because this code shouldn't change a lot in the future, - * so the cost of maintenance should be pretty low. - * *) - method! visit_typed_avalue info atv = - (* Check the current pair (value, type) *) - (match (atv.V.value, atv.V.ty) with - | V.AConcrete cv, ty -> - check_constant_value_type cv (Subst.erase_regions ty) - (* ADT case *) - | V.AAdt av, T.Adt (T.AdtId def_id, regions, tys) -> - (* Retrieve the definition to check the variant id, the number of - * parameters, etc. *) - let def = C.ctx_lookup_type_decl ctx def_id in - (* Check the number of parameters *) - assert (List.length regions = List.length def.region_params); - assert (List.length tys = List.length def.type_params); - (* Check that the variant id is consistent *) - (match (av.V.variant_id, def.T.kind) with - | Some variant_id, T.Enum variants -> - assert (T.VariantId.to_int variant_id < List.length variants) - | None, T.Struct _ -> () - | _ -> failwith "Erroneous typing"); - (* Check that the field types are correct *) - let field_types = - Subst.type_decl_get_instantiated_field_rtypes def av.V.variant_id - regions tys - in - let fields_with_types = - List.combine av.V.field_values field_types - in - List.iter - (fun ((v, ty) : V.typed_avalue * T.rty) -> assert (v.V.ty = ty)) - fields_with_types - (* Tuple case *) - | V.AAdt av, T.Adt (T.Tuple, regions, tys) -> - assert (regions = []); - assert (av.V.variant_id = None); - (* Check that the fields have the proper values - and check that there - * are as many fields as field types at the same time *) - let fields_with_types = List.combine av.V.field_values tys in - List.iter - (fun ((v, ty) : V.typed_avalue * T.rty) -> assert (v.V.ty = ty)) - fields_with_types - (* Assumed type case *) - | V.AAdt av, T.Adt (T.Assumed aty_id, regions, tys) -> ( - assert (av.V.variant_id = None); - match (aty_id, av.V.field_values, regions, tys) with - (* Box *) - | T.Box, [ boxed_value ], [], [ boxed_ty ] -> - assert (boxed_value.V.ty = boxed_ty) - | _ -> failwith "Erroneous type") - | V.ABottom, _ -> (* Nothing to check *) () - | V.ABorrow bc, T.Ref (_, ref_ty, rkind) -> ( - match (bc, rkind) with - | V.AMutBorrow (_, _, av), T.Mut -> - (* Check that the child value has the proper type *) - assert (av.V.ty = ref_ty) - | V.ASharedBorrow bid, T.Shared -> ( - (* Lookup the borrowed value to check it has the proper type *) - let _, glc = lookup_loan ek_all bid ctx in - match glc with - | Concrete (V.SharedLoan (_, sv)) - | Abstract (V.ASharedLoan (_, sv, _)) -> - assert (sv.V.ty = Subst.erase_regions ref_ty) - | _ -> failwith "Inconsistent context") - | V.AIgnoredMutBorrow (_opt_bid, av), T.Mut -> - assert (av.V.ty = ref_ty) - | ( V.AEndedIgnoredMutBorrow - { given_back_loans_proj; child; given_back_meta = _ }, - T.Mut ) -> - assert (given_back_loans_proj.V.ty = ref_ty); - assert (child.V.ty = ref_ty) - | V.AProjSharedBorrow _, T.Shared -> () - | _ -> failwith "Inconsistent context") - | V.ALoan lc, aty -> ( - match lc with - | V.AMutLoan (bid, child_av) | V.AIgnoredMutLoan (bid, child_av) - -> ( - let borrowed_aty = aloan_get_expected_child_type aty in - assert (child_av.V.ty = borrowed_aty); - (* Lookup the borrowed value to check it has the proper type *) - let glc = lookup_borrow ek_all bid ctx in - match glc with - | Concrete (V.MutBorrow (_, bv)) -> - assert (bv.V.ty = Subst.erase_regions borrowed_aty) - | Abstract (V.AMutBorrow (_, _, sv)) -> - assert ( - Subst.erase_regions sv.V.ty - = Subst.erase_regions borrowed_aty) - | _ -> failwith "Inconsistent context") - | V.ASharedLoan (_, sv, child_av) | V.AEndedSharedLoan (sv, child_av) - -> - let borrowed_aty = aloan_get_expected_child_type aty in - assert (sv.V.ty = Subst.erase_regions borrowed_aty); - (* TODO: the type of aloans doesn't make sense, see above *) - assert (child_av.V.ty = borrowed_aty) - | V.AEndedMutLoan { given_back; child; given_back_meta = _ } - | V.AEndedIgnoredMutLoan { given_back; child; given_back_meta = _ } - -> - let borrowed_aty = aloan_get_expected_child_type aty in - assert (given_back.V.ty = borrowed_aty); - assert (child.V.ty = borrowed_aty) - | V.AIgnoredSharedLoan child_av -> - assert (child_av.V.ty = aloan_get_expected_child_type aty)) - | V.ASymbolic aproj, ty -> ( - let ty1 = Subst.erase_regions ty in - match aproj with - | V.AProjLoans (sv, _) -> - let ty2 = Subst.erase_regions sv.V.sv_ty in - assert (ty1 = ty2); - (* Also check that the symbolic values contain regions of interest - - * otherwise they should have been reduced to [_] *) - let abs = Option.get info in - assert (ty_has_regions_in_set abs.regions sv.V.sv_ty) - | V.AProjBorrows (sv, proj_ty) -> - let ty2 = Subst.erase_regions sv.V.sv_ty in - assert (ty1 = ty2); - (* Also check that the symbolic values contain regions of interest - - * otherwise they should have been reduced to [_] *) - let abs = Option.get info in - assert (ty_has_regions_in_set abs.regions proj_ty) - | V.AEndedProjLoans (_msv, given_back_ls) -> - List.iter - (fun (_, proj) -> - match proj with - | V.AProjBorrows (_sv, ty') -> assert (ty' = ty) - | V.AEndedProjBorrows _ | V.AIgnoredProjBorrows -> () - | _ -> failwith "Unexpected") - given_back_ls - | V.AEndedProjBorrows _ | V.AIgnoredProjBorrows -> ()) - | V.AIgnored, _ -> () - | _ -> failwith "Erroneous typing"); - (* Continue exploring to inspect the subterms *) - super#visit_typed_avalue info atv - end - in - visitor#visit_eval_ctx (None : V.abs option) ctx - -type proj_borrows_info = { - abs_id : V.AbstractionId.id; - regions : T.RegionId.Set.t; - proj_ty : T.rty; - as_shared_value : bool; (** True if the value is below a shared borrow *) -} -[@@deriving show] - -type proj_loans_info = { - abs_id : V.AbstractionId.id; - regions : T.RegionId.Set.t; -} -[@@deriving show] - -type sv_info = { - ty : T.rty; - env_count : int; - aproj_borrows : proj_borrows_info list; - aproj_loans : proj_loans_info list; -} -[@@deriving show] - -(** Check the invariants over the symbolic values. - - - a symbolic value can't be both in proj_borrows and in the concrete env - (this is why we preemptively expand copyable symbolic values) - - if a symbolic value contains regions: there is at most one occurrence - of this value in the concrete env - - if there is an aproj_borrows in the environment, there must also be a - corresponding aproj_loans - - aproj_loans are mutually disjoint - - TODO: aproj_borrows are mutually disjoint - - the union of the aproj_loans contains the aproj_borrows applied on the - same symbolic values - *) -let check_symbolic_values (_config : C.config) (ctx : C.eval_ctx) : unit = - (* Small utility *) - let module M = V.SymbolicValueId.Map in - let infos : sv_info M.t ref = ref M.empty in - let lookup_info (sv : V.symbolic_value) : sv_info = - match M.find_opt sv.V.sv_id !infos with - | Some info -> info - | None -> - { ty = sv.sv_ty; env_count = 0; aproj_borrows = []; aproj_loans = [] } - in - let update_info (sv : V.symbolic_value) (info : sv_info) = - infos := M.add sv.sv_id info !infos - in - let add_env_sv (sv : V.symbolic_value) : unit = - let info = lookup_info sv in - let info = { info with env_count = info.env_count + 1 } in - update_info sv info - in - let add_aproj_borrows (sv : V.symbolic_value) abs_id regions proj_ty - as_shared_value : unit = - let info = lookup_info sv in - let binfo = { abs_id; regions; proj_ty; as_shared_value } in - let info = { info with aproj_borrows = binfo :: info.aproj_borrows } in - update_info sv info - in - let add_aproj_loans (sv : V.symbolic_value) abs_id regions : unit = - let info = lookup_info sv in - let linfo = { abs_id; regions } in - let info = { info with aproj_loans = linfo :: info.aproj_loans } in - update_info sv info - in - (* Visitor *) - let obj = - object - inherit [_] C.iter_eval_ctx as super - method! visit_abs _ abs = super#visit_abs (Some abs) abs - method! visit_Symbolic _ sv = add_env_sv sv - - method! visit_abstract_shared_borrows abs asb = - let abs = Option.get abs in - let visit asb = - match asb with - | V.AsbBorrow _ -> () - | AsbProjReborrows (sv, proj_ty) -> - add_aproj_borrows sv abs.abs_id abs.regions proj_ty true - in - List.iter visit asb - - method! visit_aproj abs aproj = - (let abs = Option.get abs in - match aproj with - | AProjLoans (sv, _) -> add_aproj_loans sv abs.abs_id abs.regions - | AProjBorrows (sv, proj_ty) -> - add_aproj_borrows sv abs.abs_id abs.regions proj_ty false - | AEndedProjLoans _ | AEndedProjBorrows _ | AIgnoredProjBorrows -> ()); - super#visit_aproj abs aproj - end - in - (* Collect the information *) - obj#visit_eval_ctx None ctx; - log#ldebug - (lazy - ("check_symbolic_values: collected information:\n" - ^ V.SymbolicValueId.Map.to_string (Some " ") show_sv_info !infos)); - (* Check *) - let check_info _id info = - (* TODO: check that: - * - the borrows are mutually disjoint - *) - (* A symbolic value can't be both in the regular environment and inside - * projectors of borrows in abstractions *) - assert (info.env_count = 0 || info.aproj_borrows = []); - (* A symbolic value containing borrows can't be duplicated (i.e., copied): - * it must be expanded first *) - if ty_has_borrows ctx.type_context.type_infos info.ty then - assert (info.env_count <= 1); - (* A duplicated symbolic value is necessarily primitively copyable *) - assert (info.env_count <= 1 || ty_is_primitively_copyable info.ty); - - assert (info.aproj_borrows = [] || info.aproj_loans <> []); - (* At the same time: - * - check that the loans don't intersect - * - compute the set of regions for which we project loans - *) - (* Check that the loan projectors contain the region projectors *) - let loan_regions = - List.fold_left - (fun regions linfo -> - let regions = - T.RegionId.Set.fold - (fun rid regions -> - assert (not (T.RegionId.Set.mem rid regions)); - T.RegionId.Set.add rid regions) - regions linfo.regions - in - regions) - T.RegionId.Set.empty info.aproj_loans - in - (* Check that the union of the loan projectors contains the borrow projections. *) - List.iter - (fun binfo -> - assert ( - projection_contains info.ty loan_regions binfo.proj_ty binfo.regions)) - info.aproj_borrows; - () - in - - M.iter check_info !infos - -let check_invariants (config : C.config) (ctx : C.eval_ctx) : unit = - if config.C.check_invariants then ( - log#ldebug (lazy "Checking invariants"); - check_loans_borrows_relation_invariant ctx; - check_borrowed_values_invariant config ctx; - check_typing_invariant ctx; - check_symbolic_values config ctx) - else log#ldebug (lazy "Not checking invariants (check is not activated)") - -(** Same as {!check_invariants}, but written in CPS *) -let cf_check_invariants (config : C.config) : cm_fun = - fun cf ctx -> - check_invariants config ctx; - cf ctx diff --git a/src/LlbcAst.ml b/src/LlbcAst.ml deleted file mode 100644 index 1b08f1ea..00000000 --- a/src/LlbcAst.ml +++ /dev/null @@ -1,205 +0,0 @@ -open Names -open Types -open Values -open Expressions -open Identifiers -module FunDeclId = IdGen () -module GlobalDeclId = IdGen () -open Meta - -(** A variable, as used in a function definition *) -type var = { - index : VarId.id; (** Unique variable identifier *) - name : string option; - var_ty : ety; - (** The variable type - erased type, because variables are not used - ** in function signatures: they are only used to declare the list of - ** variables manipulated by a function body *) -} -[@@deriving show] - -type assumed_fun_id = - | Replace (** [core::mem::replace] *) - | BoxNew - | BoxDeref (** [core::ops::deref::Deref::<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/src/LlbcAstUtils.ml b/src/LlbcAstUtils.ml deleted file mode 100644 index 46711d0a..00000000 --- a/src/LlbcAstUtils.ml +++ /dev/null @@ -1,73 +0,0 @@ -open LlbcAst -open Utils -module T = Types - -(** Check if a {!type:LlbcAst.statement} contains loops *) -let statement_has_loops (st : statement) : bool = - let obj = - object - inherit [_] iter_statement - method! visit_Loop _ _ = raise Found - end - in - try - obj#visit_statement () st; - false - with Found -> true - -(** Check if a {!type:LlbcAst.fun_decl} contains loops *) -let fun_decl_has_loops (fd : fun_decl) : bool = - match fd.body with - | Some body -> statement_has_loops body.body - | None -> false - -let lookup_fun_sig (fun_id : fun_id) (fun_decls : fun_decl FunDeclId.Map.t) : - fun_sig = - match fun_id with - | Regular id -> (FunDeclId.Map.find id fun_decls).signature - | Assumed aid -> Assumed.get_assumed_sig aid - -let lookup_fun_name (fun_id : fun_id) (fun_decls : fun_decl FunDeclId.Map.t) : - Names.fun_name = - match fun_id with - | Regular id -> (FunDeclId.Map.find id fun_decls).name - | Assumed aid -> Assumed.get_assumed_name aid - -(** Small utility: list the transitive parents of a region var group. - We don't do that in an efficient manner, but it doesn't matter. - - TODO: rename to "list_ancestors_..." - - This list *doesn't* include the current region. - *) -let rec list_parent_region_groups (sg : fun_sig) (gid : T.RegionGroupId.id) : - T.RegionGroupId.Set.t = - let rg = T.RegionGroupId.nth sg.regions_hierarchy gid in - let parents = - List.fold_left - (fun s gid -> - (* Compute the parents *) - let parents = list_parent_region_groups sg gid in - (* Parents U current region *) - let parents = T.RegionGroupId.Set.add gid parents in - (* Make the union with the accumulator *) - T.RegionGroupId.Set.union s parents) - T.RegionGroupId.Set.empty rg.parents - in - parents - -(** Small utility: same as {!list_parent_region_groups}, but returns an ordered list. *) -let list_ordered_parent_region_groups (sg : fun_sig) (gid : T.RegionGroupId.id) - : T.RegionGroupId.id list = - let pset = list_parent_region_groups sg gid in - let parents = - List.filter - (fun (rg : T.region_var_group) -> T.RegionGroupId.Set.mem rg.id pset) - sg.regions_hierarchy - in - let parents = List.map (fun (rg : T.region_var_group) -> rg.id) parents in - parents - -let fun_body_get_input_vars (fbody : fun_body) : var list = - let locals = List.tl fbody.locals in - Collections.List.prefix fbody.arg_count locals diff --git a/src/LlbcOfJson.ml b/src/LlbcOfJson.ml deleted file mode 100644 index 79c9b756..00000000 --- a/src/LlbcOfJson.ml +++ /dev/null @@ -1,915 +0,0 @@ -(** Functions to load LLBC ASTs from json. - - Initially, we used [ppx_derive_yojson] to automate this. - However, [ppx_derive_yojson] expects formatting to be slightly - different from what [serde_rs] generates (because it uses [Yojson.Safe.t] - and not [Yojson.Basic.t]). - - TODO: we should check all that the integer values are in the proper range - *) - -open Yojson.Basic -open Names -open OfJsonBasic -open Identifiers -open Meta -module T = Types -module V = Values -module S = Scalars -module E = Expressions -module A = LlbcAst -module TU = TypesUtils -module AU = LlbcAstUtils -module LocalFileId = IdGen () -module VirtualFileId = IdGen () - -(** The default logger *) -let log = Logging.llbc_of_json_logger - -(** A file identifier *) -type file_id = LocalId of LocalFileId.id | VirtualId of VirtualFileId.id -[@@deriving show, ord] - -module OrderedIdToFile : Collections.OrderedType with type t = file_id = struct - type t = file_id - - let compare fid0 fid1 = compare_file_id fid0 fid1 - - let to_string id = - match id with - | LocalId id -> "Local " ^ LocalFileId.to_string id - | VirtualId id -> "Virtual " ^ VirtualFileId.to_string id - - let pp_t fmt x = Format.pp_print_string fmt (to_string x) - let show_t x = to_string x -end - -module IdToFile = Collections.MakeMap (OrderedIdToFile) - -type id_to_file_map = file_name IdToFile.t - -let file_id_of_json (js : json) : (file_id, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc [ ("LocalId", id) ] -> - let* id = LocalFileId.id_of_json id in - Ok (LocalId id) - | `Assoc [ ("VirtualId", id) ] -> - let* id = VirtualFileId.id_of_json id in - Ok (VirtualId id) - | _ -> Error "") - -let file_name_of_json (js : json) : (file_name, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc [ ("Virtual", name) ] -> - let* name = string_of_json name in - Ok (Virtual name) - | `Assoc [ ("Local", name) ] -> - let* name = string_of_json name in - Ok (Local name) - | _ -> Error "") - -(** Deserialize a map from file id to file name. - - In the serialized LLBC, the files in the loc spans are refered to by their - ids, in order to save space. In a functional language like OCaml this is - not necessary: we thus replace the file ids by the file name themselves in - the AST. - The "id to file" map is thus only used in the deserialization process. - *) -let id_to_file_of_json (js : json) : (id_to_file_map, string) result = - combine_error_msgs js __FUNCTION__ - ((* The map is stored as a list of pairs (key, value): we deserialize - * this list then convert it to a map *) - let* key_values = - list_of_json (pair_of_json file_id_of_json file_name_of_json) js - in - Ok (IdToFile.of_list key_values)) - -let loc_of_json (js : json) : (loc, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc [ ("line", line); ("col", col) ] -> - let* line = int_of_json line in - let* col = int_of_json col in - Ok { line; col } - | _ -> Error "") - -let span_of_json (id_to_file : id_to_file_map) (js : json) : - (span, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc [ ("file_id", file_id); ("beg", beg_loc); ("end", end_loc) ] -> - let* file_id = file_id_of_json file_id in - let file = IdToFile.find file_id id_to_file in - let* beg_loc = loc_of_json beg_loc in - let* end_loc = loc_of_json end_loc in - Ok { file; beg_loc; end_loc } - | _ -> Error "") - -let meta_of_json (id_to_file : id_to_file_map) (js : json) : - (meta, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc [ ("span", span); ("generated_from_span", generated_from_span) ] -> - let* span = span_of_json id_to_file span in - let* generated_from_span = - option_of_json (span_of_json id_to_file) generated_from_span - in - Ok { span; generated_from_span } - | _ -> Error "") - -let path_elem_of_json (js : json) : (path_elem, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc [ ("Ident", name) ] -> - let* name = string_of_json name in - Ok (Ident name) - | `Assoc [ ("Disambiguator", d) ] -> - let* d = Disambiguator.id_of_json d in - Ok (Disambiguator d) - | _ -> Error "") - -let name_of_json (js : json) : (name, string) result = - combine_error_msgs js __FUNCTION__ (list_of_json path_elem_of_json js) - -let fun_name_of_json (js : json) : (fun_name, string) result = - combine_error_msgs js __FUNCTION__ (name_of_json js) - -let type_var_of_json (js : json) : (T.type_var, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc [ ("index", index); ("name", name) ] -> - let* index = T.TypeVarId.id_of_json index in - let* name = string_of_json name in - Ok { T.index; name } - | _ -> Error "") - -let region_var_of_json (js : json) : (T.region_var, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc [ ("index", index); ("name", name) ] -> - let* index = T.RegionVarId.id_of_json index in - let* name = string_option_of_json name in - Ok { T.index; name } - | _ -> Error "") - -let region_of_json (js : json) : (T.RegionVarId.id T.region, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `String "Static" -> Ok T.Static - | `Assoc [ ("Var", rid) ] -> - let* rid = T.RegionVarId.id_of_json rid in - Ok (T.Var rid) - | _ -> Error "") - -let erased_region_of_json (js : json) : (T.erased_region, string) result = - combine_error_msgs js __FUNCTION__ - (match js with `String "Erased" -> Ok T.Erased | _ -> Error "") - -let integer_type_of_json (js : json) : (T.integer_type, string) result = - match js with - | `String "Isize" -> Ok T.Isize - | `String "I8" -> Ok T.I8 - | `String "I16" -> Ok T.I16 - | `String "I32" -> Ok T.I32 - | `String "I64" -> Ok T.I64 - | `String "I128" -> Ok T.I128 - | `String "Usize" -> Ok T.Usize - | `String "U8" -> Ok T.U8 - | `String "U16" -> Ok T.U16 - | `String "U32" -> Ok T.U32 - | `String "U64" -> Ok T.U64 - | `String "U128" -> Ok T.U128 - | _ -> Error ("integer_type_of_json failed on: " ^ show js) - -let ref_kind_of_json (js : json) : (T.ref_kind, string) result = - match js with - | `String "Mut" -> Ok T.Mut - | `String "Shared" -> Ok T.Shared - | _ -> Error ("ref_kind_of_json failed on: " ^ show js) - -let assumed_ty_of_json (js : json) : (T.assumed_ty, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `String "Box" -> Ok T.Box - | `String "Vec" -> Ok T.Vec - | `String "Option" -> Ok T.Option - | _ -> Error "") - -let type_id_of_json (js : json) : (T.type_id, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc [ ("Adt", id) ] -> - let* id = T.TypeDeclId.id_of_json id in - Ok (T.AdtId id) - | `String "Tuple" -> Ok T.Tuple - | `Assoc [ ("Assumed", aty) ] -> - let* aty = assumed_ty_of_json aty in - Ok (T.Assumed aty) - | _ -> Error "") - -let rec ty_of_json (r_of_json : json -> ('r, string) result) (js : json) : - ('r T.ty, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc [ ("Adt", `List [ id; regions; types ]) ] -> - let* id = type_id_of_json id in - let* regions = list_of_json r_of_json regions in - let* types = list_of_json (ty_of_json r_of_json) types in - (* Sanity check *) - (match id with T.Tuple -> assert (List.length regions = 0) | _ -> ()); - Ok (T.Adt (id, regions, types)) - | `Assoc [ ("TypeVar", `List [ id ]) ] -> - let* id = T.TypeVarId.id_of_json id in - Ok (T.TypeVar id) - | `String "Bool" -> Ok Bool - | `String "Char" -> Ok Char - | `String "`Never" -> Ok Never - | `Assoc [ ("Integer", `List [ int_ty ]) ] -> - let* int_ty = integer_type_of_json int_ty in - Ok (T.Integer int_ty) - | `String "Str" -> Ok Str - | `Assoc [ ("Array", `List [ ty ]) ] -> - let* ty = ty_of_json r_of_json ty in - Ok (T.Array ty) - | `Assoc [ ("Slice", `List [ ty ]) ] -> - let* ty = ty_of_json r_of_json ty in - Ok (T.Slice ty) - | `Assoc [ ("Ref", `List [ region; ty; ref_kind ]) ] -> - let* region = r_of_json region in - let* ty = ty_of_json r_of_json ty in - let* ref_kind = ref_kind_of_json ref_kind in - Ok (T.Ref (region, ty, ref_kind)) - | _ -> Error "") - -let sty_of_json (js : json) : (T.sty, string) result = - combine_error_msgs js __FUNCTION__ (ty_of_json region_of_json js) - -let ety_of_json (js : json) : (T.ety, string) result = - combine_error_msgs js __FUNCTION__ (ty_of_json erased_region_of_json js) - -let field_of_json (id_to_file : id_to_file_map) (js : json) : - (T.field, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc [ ("meta", meta); ("name", name); ("ty", ty) ] -> - let* meta = meta_of_json id_to_file meta in - let* name = option_of_json string_of_json name in - let* ty = sty_of_json ty in - Ok { T.meta; field_name = name; field_ty = ty } - | _ -> Error "") - -let variant_of_json (id_to_file : id_to_file_map) (js : json) : - (T.variant, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc [ ("meta", meta); ("name", name); ("fields", fields) ] -> - let* meta = meta_of_json id_to_file meta in - let* name = string_of_json name in - let* fields = list_of_json (field_of_json id_to_file) fields in - Ok { T.meta; variant_name = name; fields } - | _ -> Error "") - -let type_decl_kind_of_json (id_to_file : id_to_file_map) (js : json) : - (T.type_decl_kind, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc [ ("Struct", fields) ] -> - let* fields = list_of_json (field_of_json id_to_file) fields in - Ok (T.Struct fields) - | `Assoc [ ("Enum", variants) ] -> - let* variants = list_of_json (variant_of_json id_to_file) variants in - Ok (T.Enum variants) - | `String "Opaque" -> Ok T.Opaque - | _ -> Error "") - -let region_var_group_of_json (js : json) : (T.region_var_group, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc [ ("id", id); ("regions", regions); ("parents", parents) ] -> - let* id = T.RegionGroupId.id_of_json id in - let* regions = list_of_json T.RegionVarId.id_of_json regions in - let* parents = list_of_json T.RegionGroupId.id_of_json parents in - Ok { T.id; regions; parents } - | _ -> Error "") - -let region_var_groups_of_json (js : json) : (T.region_var_groups, string) result - = - combine_error_msgs js __FUNCTION__ (list_of_json region_var_group_of_json js) - -let type_decl_of_json (id_to_file : id_to_file_map) (js : json) : - (T.type_decl, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc - [ - ("def_id", def_id); - ("meta", meta); - ("name", name); - ("region_params", region_params); - ("type_params", type_params); - ("regions_hierarchy", regions_hierarchy); - ("kind", kind); - ] -> - let* def_id = T.TypeDeclId.id_of_json def_id in - let* meta = meta_of_json id_to_file meta in - let* name = name_of_json name in - let* region_params = list_of_json region_var_of_json region_params in - let* type_params = list_of_json type_var_of_json type_params in - let* kind = type_decl_kind_of_json id_to_file kind in - let* regions_hierarchy = region_var_groups_of_json regions_hierarchy in - Ok - { - T.def_id; - meta; - name; - region_params; - type_params; - kind; - regions_hierarchy; - } - | _ -> Error "") - -let var_of_json (js : json) : (A.var, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc [ ("index", index); ("name", name); ("ty", ty) ] -> - let* index = V.VarId.id_of_json index in - let* name = string_option_of_json name in - let* var_ty = ety_of_json ty in - Ok { A.index; name; var_ty } - | _ -> Error "") - -let big_int_of_json (js : json) : (V.big_int, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Int i -> Ok (Z.of_int i) - | `String is -> Ok (Z.of_string is) - | _ -> Error "") - -(** Deserialize a {!V.scalar_value} from JSON and **check the ranges**. - - Note that in practice we also check that the values are in range - in the interpreter functions. Still, it doesn't cost much to be - a bit conservative. - *) -let scalar_value_of_json (js : json) : (V.scalar_value, string) result = - let res = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc [ ("Isize", `List [ bi ]) ] -> - let* bi = big_int_of_json bi in - Ok { V.value = bi; int_ty = Isize } - | `Assoc [ ("I8", `List [ bi ]) ] -> - let* bi = big_int_of_json bi in - Ok { V.value = bi; int_ty = I8 } - | `Assoc [ ("I16", `List [ bi ]) ] -> - let* bi = big_int_of_json bi in - Ok { V.value = bi; int_ty = I16 } - | `Assoc [ ("I32", `List [ bi ]) ] -> - let* bi = big_int_of_json bi in - Ok { V.value = bi; int_ty = I32 } - | `Assoc [ ("I64", `List [ bi ]) ] -> - let* bi = big_int_of_json bi in - Ok { V.value = bi; int_ty = I64 } - | `Assoc [ ("I128", `List [ bi ]) ] -> - let* bi = big_int_of_json bi in - Ok { V.value = bi; int_ty = I128 } - | `Assoc [ ("Usize", `List [ bi ]) ] -> - let* bi = big_int_of_json bi in - Ok { V.value = bi; int_ty = Usize } - | `Assoc [ ("U8", `List [ bi ]) ] -> - let* bi = big_int_of_json bi in - Ok { V.value = bi; int_ty = U8 } - | `Assoc [ ("U16", `List [ bi ]) ] -> - let* bi = big_int_of_json bi in - Ok { V.value = bi; int_ty = U16 } - | `Assoc [ ("U32", `List [ bi ]) ] -> - let* bi = big_int_of_json bi in - Ok { V.value = bi; int_ty = U32 } - | `Assoc [ ("U64", `List [ bi ]) ] -> - let* bi = big_int_of_json bi in - Ok { V.value = bi; int_ty = U64 } - | `Assoc [ ("U128", `List [ bi ]) ] -> - let* bi = big_int_of_json bi in - Ok { V.value = bi; int_ty = U128 } - | _ -> Error "") - in - match res with - | Error _ -> res - | Ok sv -> - if not (S.check_scalar_value_in_range sv) then ( - log#serror ("Scalar value not in range: " ^ V.show_scalar_value sv); - raise (Failure ("Scalar value not in range: " ^ V.show_scalar_value sv))); - res - -let field_proj_kind_of_json (js : json) : (E.field_proj_kind, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc [ ("ProjAdt", `List [ def_id; opt_variant_id ]) ] -> - let* def_id = T.TypeDeclId.id_of_json def_id in - let* opt_variant_id = - option_of_json T.VariantId.id_of_json opt_variant_id - in - Ok (E.ProjAdt (def_id, opt_variant_id)) - | `Assoc [ ("ProjTuple", i) ] -> - let* i = int_of_json i in - Ok (E.ProjTuple i) - | `Assoc [ ("ProjOption", variant_id) ] -> - let* variant_id = T.VariantId.id_of_json variant_id in - Ok (E.ProjOption variant_id) - | _ -> Error "") - -let projection_elem_of_json (js : json) : (E.projection_elem, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `String "Deref" -> Ok E.Deref - | `String "DerefBox" -> Ok E.DerefBox - | `Assoc [ ("Field", `List [ proj_kind; field_id ]) ] -> - let* proj_kind = field_proj_kind_of_json proj_kind in - let* field_id = T.FieldId.id_of_json field_id in - Ok (E.Field (proj_kind, field_id)) - | _ -> Error ("projection_elem_of_json failed on:" ^ show js)) - -let projection_of_json (js : json) : (E.projection, string) result = - combine_error_msgs js __FUNCTION__ (list_of_json projection_elem_of_json js) - -let place_of_json (js : json) : (E.place, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc [ ("var_id", var_id); ("projection", projection) ] -> - let* var_id = V.VarId.id_of_json var_id in - let* projection = projection_of_json projection in - Ok { E.var_id; projection } - | _ -> Error "") - -let borrow_kind_of_json (js : json) : (E.borrow_kind, string) result = - match js with - | `String "Shared" -> Ok E.Shared - | `String "Mut" -> Ok E.Mut - | `String "TwoPhaseMut" -> Ok E.TwoPhaseMut - | _ -> Error ("borrow_kind_of_json failed on:" ^ show js) - -let unop_of_json (js : json) : (E.unop, string) result = - match js with - | `String "Not" -> Ok E.Not - | `String "Neg" -> Ok E.Neg - | `Assoc [ ("Cast", `List [ src_ty; tgt_ty ]) ] -> - let* src_ty = integer_type_of_json src_ty in - let* tgt_ty = integer_type_of_json tgt_ty in - Ok (E.Cast (src_ty, tgt_ty)) - | _ -> Error ("unop_of_json failed on:" ^ show js) - -let binop_of_json (js : json) : (E.binop, string) result = - match js with - | `String "BitXor" -> Ok E.BitXor - | `String "BitAnd" -> Ok E.BitAnd - | `String "BitOr" -> Ok E.BitOr - | `String "Eq" -> Ok E.Eq - | `String "Lt" -> Ok E.Lt - | `String "Le" -> Ok E.Le - | `String "Ne" -> Ok E.Ne - | `String "Ge" -> Ok E.Ge - | `String "Gt" -> Ok E.Gt - | `String "Div" -> Ok E.Div - | `String "Rem" -> Ok E.Rem - | `String "Add" -> Ok E.Add - | `String "Sub" -> Ok E.Sub - | `String "Mul" -> Ok E.Mul - | `String "Shl" -> Ok E.Shl - | `String "Shr" -> Ok E.Shr - | _ -> Error ("binop_of_json failed on:" ^ show js) - -let constant_value_of_json (js : json) : (V.constant_value, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc [ ("Scalar", scalar_value) ] -> - let* scalar_value = scalar_value_of_json scalar_value in - Ok (V.Scalar scalar_value) - | `Assoc [ ("Bool", v) ] -> - let* v = bool_of_json v in - Ok (V.Bool v) - | `Assoc [ ("Char", v) ] -> - let* v = char_of_json v in - Ok (V.Char v) - | `Assoc [ ("String", v) ] -> - let* v = string_of_json v in - Ok (V.String v) - | _ -> Error "") - -let operand_of_json (js : json) : (E.operand, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc [ ("Copy", place) ] -> - let* place = place_of_json place in - Ok (E.Copy place) - | `Assoc [ ("Move", place) ] -> - let* place = place_of_json place in - Ok (E.Move place) - | `Assoc [ ("Const", `List [ ty; cv ]) ] -> - let* ty = ety_of_json ty in - let* cv = constant_value_of_json cv in - Ok (E.Constant (ty, cv)) - | _ -> Error "") - -let aggregate_kind_of_json (js : json) : (E.aggregate_kind, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `String "AggregatedTuple" -> Ok E.AggregatedTuple - | `Assoc [ ("AggregatedOption", `List [ variant_id; ty ]) ] -> - let* variant_id = T.VariantId.id_of_json variant_id in - let* ty = ety_of_json ty in - Ok (E.AggregatedOption (variant_id, ty)) - | `Assoc [ ("AggregatedAdt", `List [ id; opt_variant_id; regions; tys ]) ] - -> - let* id = T.TypeDeclId.id_of_json id in - let* opt_variant_id = - option_of_json T.VariantId.id_of_json opt_variant_id - in - let* regions = list_of_json erased_region_of_json regions in - let* tys = list_of_json ety_of_json tys in - Ok (E.AggregatedAdt (id, opt_variant_id, regions, tys)) - | _ -> Error "") - -let rvalue_of_json (js : json) : (E.rvalue, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc [ ("Use", op) ] -> - let* op = operand_of_json op in - Ok (E.Use op) - | `Assoc [ ("Ref", `List [ place; borrow_kind ]) ] -> - let* place = place_of_json place in - let* borrow_kind = borrow_kind_of_json borrow_kind in - Ok (E.Ref (place, borrow_kind)) - | `Assoc [ ("UnaryOp", `List [ unop; op ]) ] -> - let* unop = unop_of_json unop in - let* op = operand_of_json op in - Ok (E.UnaryOp (unop, op)) - | `Assoc [ ("BinaryOp", `List [ binop; op1; op2 ]) ] -> - let* binop = binop_of_json binop in - let* op1 = operand_of_json op1 in - let* op2 = operand_of_json op2 in - Ok (E.BinaryOp (binop, op1, op2)) - | `Assoc [ ("Discriminant", place) ] -> - let* place = place_of_json place in - Ok (E.Discriminant place) - | `Assoc [ ("Aggregate", `List [ aggregate_kind; ops ]) ] -> - let* aggregate_kind = aggregate_kind_of_json aggregate_kind in - let* ops = list_of_json operand_of_json ops in - Ok (E.Aggregate (aggregate_kind, ops)) - | _ -> Error "") - -let assumed_fun_id_of_json (js : json) : (A.assumed_fun_id, string) result = - match js with - | `String "Replace" -> Ok A.Replace - | `String "BoxNew" -> Ok A.BoxNew - | `String "BoxDeref" -> Ok A.BoxDeref - | `String "BoxDerefMut" -> Ok A.BoxDerefMut - | `String "BoxFree" -> Ok A.BoxFree - | `String "VecNew" -> Ok A.VecNew - | `String "VecPush" -> Ok A.VecPush - | `String "VecInsert" -> Ok A.VecInsert - | `String "VecLen" -> Ok A.VecLen - | `String "VecIndex" -> Ok A.VecIndex - | `String "VecIndexMut" -> Ok A.VecIndexMut - | _ -> Error ("assumed_fun_id_of_json failed on:" ^ show js) - -let fun_id_of_json (js : json) : (A.fun_id, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc [ ("Regular", id) ] -> - let* id = A.FunDeclId.id_of_json id in - Ok (A.Regular id) - | `Assoc [ ("Assumed", fid) ] -> - let* fid = assumed_fun_id_of_json fid in - Ok (A.Assumed fid) - | _ -> Error "") - -let assertion_of_json (js : json) : (A.assertion, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc [ ("cond", cond); ("expected", expected) ] -> - let* cond = operand_of_json cond in - let* expected = bool_of_json expected in - Ok { A.cond; expected } - | _ -> Error "") - -let fun_sig_of_json (js : json) : (A.fun_sig, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc - [ - ("region_params", region_params); - ("num_early_bound_regions", num_early_bound_regions); - ("regions_hierarchy", regions_hierarchy); - ("type_params", type_params); - ("inputs", inputs); - ("output", output); - ] -> - let* region_params = list_of_json region_var_of_json region_params in - let* num_early_bound_regions = int_of_json num_early_bound_regions in - let* regions_hierarchy = region_var_groups_of_json regions_hierarchy in - let* type_params = list_of_json type_var_of_json type_params in - let* inputs = list_of_json sty_of_json inputs in - let* output = sty_of_json output in - Ok - { - A.region_params; - num_early_bound_regions; - regions_hierarchy; - type_params; - inputs; - output; - } - | _ -> Error "") - -let call_of_json (js : json) : (A.call, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc - [ - ("func", func); - ("region_args", region_args); - ("type_args", type_args); - ("args", args); - ("dest", dest); - ] -> - let* func = fun_id_of_json func in - let* region_args = list_of_json erased_region_of_json region_args in - let* type_args = list_of_json ety_of_json type_args in - let* args = list_of_json operand_of_json args in - let* dest = place_of_json dest in - Ok { A.func; region_args; type_args; args; dest } - | _ -> Error "") - -let rec statement_of_json (id_to_file : id_to_file_map) (js : json) : - (A.statement, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc [ ("meta", meta); ("content", content) ] -> - let* meta = meta_of_json id_to_file meta in - let* content = raw_statement_of_json id_to_file content in - Ok { A.meta; content } - | _ -> Error "") - -and raw_statement_of_json (id_to_file : id_to_file_map) (js : json) : - (A.raw_statement, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc [ ("Assign", `List [ place; rvalue ]) ] -> - let* place = place_of_json place in - let* rvalue = rvalue_of_json rvalue in - Ok (A.Assign (place, rvalue)) - | `Assoc [ ("AssignGlobal", `List [ dst; global ]) ] -> - let* dst = V.VarId.id_of_json dst in - let* global = A.GlobalDeclId.id_of_json global in - Ok (A.AssignGlobal { dst; global }) - | `Assoc [ ("FakeRead", place) ] -> - let* place = place_of_json place in - Ok (A.FakeRead place) - | `Assoc [ ("SetDiscriminant", `List [ place; variant_id ]) ] -> - let* place = place_of_json place in - let* variant_id = T.VariantId.id_of_json variant_id in - Ok (A.SetDiscriminant (place, variant_id)) - | `Assoc [ ("Drop", place) ] -> - let* place = place_of_json place in - Ok (A.Drop place) - | `Assoc [ ("Assert", assertion) ] -> - let* assertion = assertion_of_json assertion in - Ok (A.Assert assertion) - | `Assoc [ ("Call", call) ] -> - let* call = call_of_json call in - Ok (A.Call call) - | `String "Panic" -> Ok A.Panic - | `String "Return" -> Ok A.Return - | `Assoc [ ("Break", i) ] -> - let* i = int_of_json i in - Ok (A.Break i) - | `Assoc [ ("Continue", i) ] -> - let* i = int_of_json i in - Ok (A.Continue i) - | `String "Nop" -> Ok A.Nop - | `Assoc [ ("Sequence", `List [ st1; st2 ]) ] -> - let* st1 = statement_of_json id_to_file st1 in - let* st2 = statement_of_json id_to_file st2 in - Ok (A.Sequence (st1, st2)) - | `Assoc [ ("Switch", `List [ op; tgt ]) ] -> - let* op = operand_of_json op in - let* tgt = switch_targets_of_json id_to_file tgt in - Ok (A.Switch (op, tgt)) - | `Assoc [ ("Loop", st) ] -> - let* st = statement_of_json id_to_file st in - Ok (A.Loop st) - | _ -> Error "") - -and switch_targets_of_json (id_to_file : id_to_file_map) (js : json) : - (A.switch_targets, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc [ ("If", `List [ st1; st2 ]) ] -> - let* st1 = statement_of_json id_to_file st1 in - let* st2 = statement_of_json id_to_file st2 in - Ok (A.If (st1, st2)) - | `Assoc [ ("SwitchInt", `List [ int_ty; tgts; otherwise ]) ] -> - let* int_ty = integer_type_of_json int_ty in - let* tgts = - list_of_json - (pair_of_json - (list_of_json scalar_value_of_json) - (statement_of_json id_to_file)) - tgts - in - let* otherwise = statement_of_json id_to_file otherwise in - Ok (A.SwitchInt (int_ty, tgts, otherwise)) - | _ -> Error "") - -let fun_body_of_json (id_to_file : id_to_file_map) (js : json) : - (A.fun_body, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc - [ - ("meta", meta); - ("arg_count", arg_count); - ("locals", locals); - ("body", body); - ] -> - let* meta = meta_of_json id_to_file meta in - let* arg_count = int_of_json arg_count in - let* locals = list_of_json var_of_json locals in - let* body = statement_of_json id_to_file body in - Ok { A.meta; arg_count; locals; body } - | _ -> Error "") - -let fun_decl_of_json (id_to_file : id_to_file_map) (js : json) : - (A.fun_decl, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc - [ - ("def_id", def_id); - ("meta", meta); - ("name", name); - ("signature", signature); - ("body", body); - ] -> - let* def_id = A.FunDeclId.id_of_json def_id in - let* meta = meta_of_json id_to_file meta in - let* name = fun_name_of_json name in - let* signature = fun_sig_of_json signature in - let* body = option_of_json (fun_body_of_json id_to_file) body in - Ok - { A.def_id; meta; name; signature; body; is_global_decl_body = false } - | _ -> Error "") - -(* Strict type for the number of function declarations (see {!global_to_fun_id} below) *) -type global_id_converter = { fun_count : int } [@@deriving show] - -(** Converts a global id to its corresponding function id. - To do so, it adds the global id to the number of function declarations : - We have the bijection [global_fun_id <=> global_id + fun_id_count]. -*) -let global_to_fun_id (conv : global_id_converter) (gid : A.GlobalDeclId.id) : - A.FunDeclId.id = - A.FunDeclId.of_int (A.GlobalDeclId.to_int gid + conv.fun_count) - -(* Converts a global declaration to a function declaration. - *) -let global_decl_of_json (id_to_file : id_to_file_map) (js : json) - (gid_conv : global_id_converter) : - (A.global_decl * A.fun_decl, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc - [ - ("def_id", def_id); - ("meta", meta); - ("name", name); - ("ty", ty); - ("body", body); - ] -> - let* global_id = A.GlobalDeclId.id_of_json def_id in - let fun_id = global_to_fun_id gid_conv global_id in - let* meta = meta_of_json id_to_file meta in - let* name = fun_name_of_json name in - let* ty = ety_of_json ty in - let* body = option_of_json (fun_body_of_json id_to_file) body in - let signature : A.fun_sig = - { - region_params = []; - num_early_bound_regions = 0; - regions_hierarchy = []; - type_params = []; - inputs = []; - output = TU.ety_no_regions_to_sty ty; - } - in - Ok - ( { A.def_id = global_id; meta; body_id = fun_id; name; ty }, - { - A.def_id = fun_id; - meta; - name; - signature; - body; - is_global_decl_body = true; - } ) - | _ -> Error "") - -let g_declaration_group_of_json (id_of_json : json -> ('id, string) result) - (js : json) : ('id Crates.g_declaration_group, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc [ ("NonRec", `List [ id ]) ] -> - let* id = id_of_json id in - Ok (Crates.NonRec id) - | `Assoc [ ("Rec", `List [ ids ]) ] -> - let* ids = list_of_json id_of_json ids in - Ok (Crates.Rec ids) - | _ -> Error "") - -let type_declaration_group_of_json (js : json) : - (Crates.type_declaration_group, string) result = - combine_error_msgs js __FUNCTION__ - (g_declaration_group_of_json T.TypeDeclId.id_of_json js) - -let fun_declaration_group_of_json (js : json) : - (Crates.fun_declaration_group, string) result = - combine_error_msgs js __FUNCTION__ - (g_declaration_group_of_json A.FunDeclId.id_of_json js) - -let global_declaration_group_of_json (js : json) : - (A.GlobalDeclId.id, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc [ ("NonRec", `List [ id ]) ] -> - let* id = A.GlobalDeclId.id_of_json id in - Ok id - | `Assoc [ ("Rec", `List [ _ ]) ] -> Error "got mutually dependent globals" - | _ -> Error "") - -let declaration_group_of_json (js : json) : - (Crates.declaration_group, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc [ ("Type", `List [ decl ]) ] -> - let* decl = type_declaration_group_of_json decl in - Ok (Crates.Type decl) - | `Assoc [ ("Fun", `List [ decl ]) ] -> - let* decl = fun_declaration_group_of_json decl in - Ok (Crates.Fun decl) - | `Assoc [ ("Global", `List [ decl ]) ] -> - let* id = global_declaration_group_of_json decl in - Ok (Crates.Global id) - | _ -> Error "") - -let length_of_json_list (js : json) : (int, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `List jsl -> Ok (List.length jsl) - | _ -> Error ("not a list: " ^ show js)) - -let llbc_crate_of_json (js : json) : (Crates.llbc_crate, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc - [ - ("name", name); - ("id_to_file", id_to_file); - ("declarations", declarations); - ("types", types); - ("functions", functions); - ("globals", globals); - ] -> - (* We first deserialize the declaration groups (which simply contain ids) - * and all the declarations *butù* the globals *) - let* name = string_of_json name in - let* id_to_file = id_to_file_of_json id_to_file in - let* declarations = - list_of_json declaration_group_of_json declarations - in - let* types = list_of_json (type_decl_of_json id_to_file) types in - let* functions = list_of_json (fun_decl_of_json id_to_file) functions in - (* When deserializing the globals, we split the global declarations - * between the globals themselves and their bodies, which are simply - * functions with no arguments. We add the global bodies to the list - * of function declarations: the (fresh) ids we use for those bodies - * are simply given by: [num_functions + global_id] *) - let gid_conv = { fun_count = List.length functions } in - let* globals = - list_of_json - (fun js -> global_decl_of_json id_to_file js gid_conv) - globals - in - let globals, global_bodies = List.split globals in - Ok - { - Crates.name; - declarations; - types; - functions = functions @ global_bodies; - globals; - } - | _ -> Error "") diff --git a/src/Logging.ml b/src/Logging.ml deleted file mode 100644 index e83f25f8..00000000 --- a/src/Logging.ml +++ /dev/null @@ -1,179 +0,0 @@ -module H = Easy_logging.Handlers -module L = Easy_logging.Logging - -let _ = L.make_logger "MainLogger" Debug [ Cli Debug ] - -(** The main logger *) -let main_log = L.get_logger "MainLogger" - -(** Below, we create subgloggers for various submodules, so that we can precisely - toggle logging on/off, depending on which information we need *) - -(** Logger for LlbcOfJson *) -let llbc_of_json_logger = L.get_logger "MainLogger.LlbcOfJson" - -(** Logger for PrePasses *) -let pre_passes_log = L.get_logger "MainLogger.PrePasses" - -(** Logger for Translate *) -let translate_log = L.get_logger "MainLogger.Translate" - -(** Logger for PureUtils *) -let pure_utils_log = L.get_logger "MainLogger.PureUtils" - -(** Logger for SymbolicToPure *) -let symbolic_to_pure_log = L.get_logger "MainLogger.SymbolicToPure" - -(** Logger for PureMicroPasses *) -let pure_micro_passes_log = L.get_logger "MainLogger.PureMicroPasses" - -(** Logger for PureToExtract *) -let pure_to_extract_log = L.get_logger "MainLogger.PureToExtract" - -(** Logger for Interpreter *) -let interpreter_log = L.get_logger "MainLogger.Interpreter" - -(** Logger for InterpreterStatements *) -let statements_log = L.get_logger "MainLogger.Interpreter.Statements" - -(** Logger for InterpreterExpressions *) -let expressions_log = L.get_logger "MainLogger.Interpreter.Expressions" - -(** Logger for InterpreterPaths *) -let paths_log = L.get_logger "MainLogger.Interpreter.Paths" - -(** Logger for InterpreterExpansion *) -let expansion_log = L.get_logger "MainLogger.Interpreter.Expansion" - -(** Logger for InterpreterBorrows *) -let borrows_log = L.get_logger "MainLogger.Interpreter.Borrows" - -(** Logger for Invariants *) -let invariants_log = L.get_logger "MainLogger.Interpreter.Invariants" - -(** Terminal colors - TODO: comes from easy_logging (did not manage to reuse the module directly) *) -type color = - | Default - | Black - | Red - | Green - | Yellow - | Blue - | Magenta - | Cyan - | Gray - | White - | LRed - | LGreen - | LYellow - | LBlue - | LMagenta - | LCyan - | LGray - -(** Terminal styles - TODO: comes from easy_logging (did not manage to reuse the module directly) *) -type format = Bold | Underline | Invert | Fg of color | Bg of color - -(** TODO: comes from easy_logging (did not manage to reuse the module directly) *) -let to_fg_code c = - match c with - | Default -> 39 - | Black -> 30 - | Red -> 31 - | Green -> 32 - | Yellow -> 33 - | Blue -> 34 - | Magenta -> 35 - | Cyan -> 36 - | Gray -> 90 - | White -> 97 - | LRed -> 91 - | LGreen -> 92 - | LYellow -> 93 - | LBlue -> 94 - | LMagenta -> 95 - | LCyan -> 96 - | LGray -> 37 - -(** TODO: comes from easy_logging (did not manage to reuse the module directly) *) -let to_bg_code c = - match c with - | Default -> 49 - | Black -> 40 - | Red -> 41 - | Green -> 42 - | Yellow -> 43 - | Blue -> 44 - | Magenta -> 45 - | Cyan -> 46 - | Gray -> 100 - | White -> 107 - | LRed -> 101 - | LGreen -> 102 - | LYellow -> 103 - | LBlue -> 104 - | LMagenta -> 105 - | LCyan -> 106 - | LGray -> 47 - -(** TODO: comes from easy_logging (did not manage to reuse the module directly) *) -let style_to_codes s = - match s with - | Bold -> (1, 21) - | Underline -> (4, 24) - | Invert -> (7, 27) - | Fg c -> (to_fg_code c, to_fg_code Default) - | Bg c -> (to_bg_code c, to_bg_code Default) - -(** TODO: comes from easy_logging (did not manage to reuse the module directly) - I made a minor modifications, though. *) -let level_to_color (lvl : L.level) = - match lvl with - | L.Flash -> LMagenta - | Error -> LRed - | Warning -> LYellow - | Info -> LGreen - | Trace -> Cyan - | Debug -> LBlue - | NoLevel -> Default - -(** [format styles str] formats [str] to the given [styles] - - TODO: comes from {{: http://ocamlverse.net/content/documentation_guidelines.html}[easy_logging]} - (did not manage to reuse the module directly) -*) -let rec format styles str = - match styles with - | (_ as s) :: styles' -> - let set, reset = style_to_codes s in - Printf.sprintf "\027[%dm%s\027[%dm" set (format styles' str) reset - | [] -> str - -(** TODO: comes from {{: http://ocamlverse.net/content/documentation_guidelines.html}[easy_logging]} - (did not manage to reuse the module directly) *) -let format_tags (tags : string list) = - match tags with - | [] -> "" - | _ -> - let elems_str = String.concat " | " tags in - "[" ^ elems_str ^ "] " - -(* Change the formatters *) -let main_logger_handler = - (* TODO: comes from easy_logging *) - let formatter (item : L.log_item) : string = - let item_level_fmt = - format [ Fg (level_to_color item.level) ] (L.show_level item.level) - and item_msg_fmt = - match item.level with - | Flash -> format [ Fg Black; Bg LMagenta ] item.msg - | _ -> item.msg - in - - Format.pp_set_max_indent Format.str_formatter 200; - Format.sprintf "@[[%-15s] %s%s@]" item_level_fmt (format_tags item.tags) - item_msg_fmt - in - (* There should be exactly one handler *) - let handlers = main_log#get_handlers in - List.iter (fun h -> H.set_formatter h formatter) handlers; - match handlers with [ handler ] -> handler | _ -> failwith "Unexpected" diff --git a/src/Meta.ml b/src/Meta.ml deleted file mode 100644 index f0e4ca04..00000000 --- a/src/Meta.ml +++ /dev/null @@ -1,44 +0,0 @@ -(** Meta data like code spans *) - -(** A line location *) -type loc = { - line : int; (** The (1-based) line number. *) - col : int; (** The (0-based) column offset. *) -} -[@@deriving show] - -type file_name = - | Virtual of string (** A remapped path (namely paths into stdlib) *) - | Local of string - (** A local path (a file coming from the current crate for instance) *) -[@@deriving show] - -(** Span data *) -type span = { file : file_name; beg_loc : loc; end_loc : loc } [@@deriving show] - -type meta = { - span : span; - (** The source code span. - - If this meta information is for a statement/terminator coming from a macro - expansion/inlining/etc., this span is (in case of macros) for the macro - before expansion (i.e., the location the code where the user wrote the call - to the macro). - - Ex: - {[ - // Below, we consider the spans for the statements inside `test` - - // the statement we consider, which gets inlined in `test` - VV - macro_rules! macro { ... st ... } // `generated_from_span` refers to this location - - fn test() { - macro!(); // <-- `span` refers to this location - } - ]} - *) - generated_from_span : span option; - (** Where the code actually comes from, in case of macro expansion/inlining/etc. *) -} -[@@deriving show] diff --git a/src/Names.ml b/src/Names.ml deleted file mode 100644 index a27db161..00000000 --- a/src/Names.ml +++ /dev/null @@ -1,80 +0,0 @@ -open Identifiers -module Disambiguator = IdGen () - -(** See the comments for [Name] *) -type path_elem = Ident of string | Disambiguator of Disambiguator.id -[@@deriving show, ord] - -(** A name such as: [std::collections::vector] (which would be represented as - [[Ident "std"; Ident "collections"; Ident "vector"]]) - - - A name really is a list of strings. However, we sometimes need to - introduce unique indices to disambiguate. This mostly happens because - of "impl" blocks in Rust: - {[ - impl<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/src/OfJsonBasic.ml b/src/OfJsonBasic.ml deleted file mode 100644 index 07daf03d..00000000 --- a/src/OfJsonBasic.ml +++ /dev/null @@ -1,75 +0,0 @@ -(** This module defines various basic utilities for json deserialization. - - *) - -open Yojson.Basic - -type json = t - -let ( let* ) o f = match o with Error e -> Error e | Ok x -> f x - -let combine_error_msgs js msg res : ('a, string) result = - match res with - | Ok x -> Ok x - | Error e -> Error ("[" ^ msg ^ "]" ^ " failed on: " ^ show js ^ "\n\n" ^ e) - -let bool_of_json (js : json) : (bool, string) result = - match js with - | `Bool b -> Ok b - | _ -> Error ("bool_of_json: not a bool: " ^ show js) - -let int_of_json (js : json) : (int, string) result = - match js with - | `Int i -> Ok i - | _ -> Error ("int_of_json: not an int: " ^ show js) - -let char_of_json (js : json) : (char, string) result = - match js with - | `String c -> - if String.length c = 1 then Ok c.[0] - else Error ("char_of_json: stricly more than one character in: " ^ show js) - | _ -> Error ("char_of_json: not a char: " ^ show js) - -let rec of_json_list (a_of_json : json -> ('a, string) result) (jsl : json list) - : ('a list, string) result = - match jsl with - | [] -> Ok [] - | x :: jsl' -> - let* x = a_of_json x in - let* jsl' = of_json_list a_of_json jsl' in - Ok (x :: jsl') - -let pair_of_json (a_of_json : json -> ('a, string) result) - (b_of_json : json -> ('b, string) result) (js : json) : - ('a * 'b, string) result = - match js with - | `List [ a; b ] -> - let* a = a_of_json a in - let* b = b_of_json b in - Ok (a, b) - | _ -> Error ("pair_of_json failed on: " ^ show js) - -let list_of_json (a_of_json : json -> ('a, string) result) (js : json) : - ('a list, string) result = - combine_error_msgs js "list_of_json" - (match js with - | `List jsl -> of_json_list a_of_json jsl - | _ -> Error ("not a list: " ^ show js)) - -let string_of_json (js : json) : (string, string) result = - match js with - | `String str -> Ok str - | _ -> Error ("string_of_json: not a string: " ^ show js) - -let option_of_json (a_of_json : json -> ('a, string) result) (js : json) : - ('a option, string) result = - combine_error_msgs js "option_of_json" - (match js with - | `Null -> Ok None - | _ -> - let* x = a_of_json js in - Ok (Some x)) - -let string_option_of_json (js : json) : (string option, string) result = - combine_error_msgs js "string_option_of_json" - (option_of_json string_of_json js) diff --git a/src/PrePasses.ml b/src/PrePasses.ml deleted file mode 100644 index a09ae476..00000000 --- a/src/PrePasses.ml +++ /dev/null @@ -1,54 +0,0 @@ -(** This files contains passes we apply on the AST *before* calling the - (concrete/symbolic) interpreter on it - *) - -module T = Types -module V = Values -module E = Expressions -module C = Contexts -module A = LlbcAst -module L = Logging - -let log = L.pre_passes_log - -(** Rustc inserts a lot of drops before the assignments. - We consider those drops are part of the assignment, and splitting the - drop and the assignment is problematic for us because it can introduce - [⊥] under borrows. For instance, we encountered situations like the - following one: - - {[ - drop( *x ); // Illegal! Inserts a ⊥ under a borrow - *x = move ...; - ]} - - TODO: this is not necessary anymore - *) -let filter_drop_assigns (f : A.fun_decl) : A.fun_decl = - (* The visitor *) - let obj = - object (self) - inherit [_] A.map_statement as super - - method! visit_Sequence env st1 st2 = - match (st1.content, st2.content) with - | Drop p1, Assign (p2, _) -> - if p1 = p2 then (self#visit_statement env st2).content - else super#visit_Sequence env st1 st2 - | Drop p1, Sequence ({ content = Assign (p2, _); meta = _ }, _) -> - if p1 = p2 then (self#visit_statement env st2).content - else super#visit_Sequence env st1 st2 - | _ -> super#visit_Sequence env st1 st2 - end - in - (* Map *) - let body = - match f.body with - | Some body -> Some { body with body = obj#visit_statement () body.body } - | None -> None - in - { f with body } - -let apply_passes (m : Crates.llbc_crate) : Crates.llbc_crate = - let functions = List.map filter_drop_assigns m.functions in - { m with functions } diff --git a/src/Print.ml b/src/Print.ml deleted file mode 100644 index 03cab6ee..00000000 --- a/src/Print.ml +++ /dev/null @@ -1,1283 +0,0 @@ -open Names -module T = Types -module TU = TypesUtils -module V = Values -module VU = ValuesUtils -module E = Expressions -module A = LlbcAst -module C = Contexts - -let option_to_string (to_string : 'a -> string) (x : 'a option) : string = - match x with Some x -> "Some (" ^ to_string x ^ ")" | None -> "None" - -let name_to_string (name : name) : string = Names.name_to_string name -let fun_name_to_string (name : fun_name) : string = name_to_string name -let global_name_to_string (name : global_name) : string = name_to_string name - -(** Pretty-printing for types *) -module Types = struct - let type_var_to_string (tv : T.type_var) : string = tv.name - - let region_var_to_string (rv : T.region_var) : string = - match rv.name with - | Some name -> name - | None -> T.RegionVarId.to_string rv.index - - let region_var_id_to_string (rid : T.RegionVarId.id) : string = - "rv@" ^ T.RegionVarId.to_string rid - - let region_id_to_string (rid : T.RegionId.id) : string = - "r@" ^ T.RegionId.to_string rid - - let region_to_string (rid_to_string : 'rid -> string) (r : 'rid T.region) : - string = - match r with Static -> "'static" | Var rid -> rid_to_string rid - - let erased_region_to_string (_ : T.erased_region) : string = "'_" - - let ref_kind_to_string (rk : T.ref_kind) : string = - match rk with Mut -> "Mut" | Shared -> "Shared" - - let assumed_ty_to_string (_ : T.assumed_ty) : string = "Box" - - type 'r type_formatter = { - r_to_string : 'r -> string; - type_var_id_to_string : T.TypeVarId.id -> string; - type_decl_id_to_string : T.TypeDeclId.id -> string; - } - - type stype_formatter = T.RegionVarId.id T.region type_formatter - type rtype_formatter = T.RegionId.id T.region type_formatter - type etype_formatter = T.erased_region type_formatter - - let integer_type_to_string = function - | T.Isize -> "isize" - | T.I8 -> "i8" - | T.I16 -> "i16" - | T.I32 -> "i32" - | T.I64 -> "i64" - | T.I128 -> "i128" - | T.Usize -> "usize" - | T.U8 -> "u8" - | T.U16 -> "u16" - | T.U32 -> "u32" - | T.U64 -> "u64" - | T.U128 -> "u128" - - let type_id_to_string (fmt : 'r type_formatter) (id : T.type_id) : string = - match id with - | T.AdtId id -> fmt.type_decl_id_to_string id - | T.Tuple -> "" - | T.Assumed aty -> ( - match aty with - | Box -> "alloc::boxed::Box" - | Vec -> "alloc::vec::Vec" - | Option -> "core::option::Option") - - let rec ty_to_string (fmt : 'r type_formatter) (ty : 'r T.ty) : string = - match ty with - | T.Adt (id, regions, tys) -> - let is_tuple = match id with T.Tuple -> true | _ -> false in - let params = params_to_string fmt is_tuple regions tys in - type_id_to_string fmt id ^ params - | T.TypeVar tv -> fmt.type_var_id_to_string tv - | T.Bool -> "bool" - | T.Char -> "char" - | T.Never -> "⊥" - | T.Integer int_ty -> integer_type_to_string int_ty - | T.Str -> "str" - | T.Array aty -> "[" ^ ty_to_string fmt aty ^ "; ?]" - | T.Slice sty -> "[" ^ ty_to_string fmt sty ^ "]" - | T.Ref (r, rty, ref_kind) -> ( - match ref_kind with - | T.Mut -> - "&" ^ fmt.r_to_string r ^ " mut (" ^ ty_to_string fmt rty ^ ")" - | T.Shared -> - "&" ^ fmt.r_to_string r ^ " (" ^ ty_to_string fmt rty ^ ")") - - and params_to_string (fmt : 'r type_formatter) (is_tuple : bool) - (regions : 'r list) (types : 'r T.ty list) : string = - let regions = List.map fmt.r_to_string regions in - let types = List.map (ty_to_string fmt) types in - let params = String.concat ", " (List.append regions types) in - if is_tuple then "(" ^ params ^ ")" - else if List.length regions + List.length types > 0 then "<" ^ params ^ ">" - else "" - - let sty_to_string (fmt : stype_formatter) (ty : T.sty) : string = - ty_to_string fmt ty - - let rty_to_string (fmt : rtype_formatter) (ty : T.rty) : string = - ty_to_string fmt ty - - let ety_to_string (fmt : etype_formatter) (ty : T.ety) : string = - ty_to_string fmt ty - - let field_to_string fmt (f : T.field) : string = - match f.field_name with - | Some field_name -> field_name ^ " : " ^ ty_to_string fmt f.field_ty - | None -> ty_to_string fmt f.field_ty - - let variant_to_string fmt (v : T.variant) : string = - v.variant_name ^ "(" - ^ String.concat ", " (List.map (field_to_string fmt) v.fields) - ^ ")" - - let type_decl_to_string (type_decl_id_to_string : T.TypeDeclId.id -> string) - (def : T.type_decl) : string = - let regions = def.region_params in - let types = def.type_params in - let rid_to_string rid = - match List.find_opt (fun rv -> rv.T.index = rid) regions with - | Some rv -> region_var_to_string rv - | None -> failwith "Unreachable" - in - let r_to_string = region_to_string rid_to_string in - let type_var_id_to_string id = - match List.find_opt (fun tv -> tv.T.index = id) types with - | Some tv -> type_var_to_string tv - | None -> failwith "Unreachable" - in - let fmt = { r_to_string; type_var_id_to_string; type_decl_id_to_string } in - let name = name_to_string def.name in - let params = - if List.length regions + List.length types > 0 then - let regions = List.map region_var_to_string regions in - let types = List.map type_var_to_string types in - let params = String.concat ", " (List.append regions types) in - "<" ^ params ^ ">" - else "" - in - match def.kind with - | T.Struct fields -> - if List.length fields > 0 then - let fields = - String.concat "," - (List.map (fun f -> "\n " ^ field_to_string fmt f) fields) - in - "struct " ^ name ^ params ^ "{" ^ fields ^ "}" - else "struct " ^ name ^ params ^ "{}" - | T.Enum variants -> - let variants = - List.map (fun v -> "| " ^ variant_to_string fmt v) variants - in - let variants = String.concat "\n" variants in - "enum " ^ name ^ params ^ " =\n" ^ variants - | T.Opaque -> "opaque type " ^ name ^ params -end - -module PT = Types (* local module *) - -(** Pretty-printing for values *) -module Values = struct - type value_formatter = { - rvar_to_string : T.RegionVarId.id -> string; - r_to_string : T.RegionId.id -> string; - type_var_id_to_string : T.TypeVarId.id -> string; - type_decl_id_to_string : T.TypeDeclId.id -> string; - adt_variant_to_string : T.TypeDeclId.id -> T.VariantId.id -> string; - var_id_to_string : V.VarId.id -> string; - adt_field_names : - T.TypeDeclId.id -> T.VariantId.id option -> string list option; - } - - let value_to_etype_formatter (fmt : value_formatter) : PT.etype_formatter = - { - PT.r_to_string = PT.erased_region_to_string; - PT.type_var_id_to_string = fmt.type_var_id_to_string; - PT.type_decl_id_to_string = fmt.type_decl_id_to_string; - } - - let value_to_rtype_formatter (fmt : value_formatter) : PT.rtype_formatter = - { - PT.r_to_string = PT.region_to_string fmt.r_to_string; - PT.type_var_id_to_string = fmt.type_var_id_to_string; - PT.type_decl_id_to_string = fmt.type_decl_id_to_string; - } - - let value_to_stype_formatter (fmt : value_formatter) : PT.stype_formatter = - { - PT.r_to_string = PT.region_to_string fmt.rvar_to_string; - PT.type_var_id_to_string = fmt.type_var_id_to_string; - PT.type_decl_id_to_string = fmt.type_decl_id_to_string; - } - - let var_id_to_string (id : V.VarId.id) : string = - "var@" ^ V.VarId.to_string id - - let big_int_to_string (bi : V.big_int) : string = Z.to_string bi - - let scalar_value_to_string (sv : V.scalar_value) : string = - big_int_to_string sv.value ^ ": " ^ PT.integer_type_to_string sv.int_ty - - let constant_value_to_string (cv : V.constant_value) : string = - match cv with - | Scalar sv -> scalar_value_to_string sv - | Bool b -> Bool.to_string b - | Char c -> String.make 1 c - | String s -> s - - let symbolic_value_id_to_string (id : V.SymbolicValueId.id) : string = - "s@" ^ V.SymbolicValueId.to_string id - - let symbolic_value_to_string (fmt : PT.rtype_formatter) - (sv : V.symbolic_value) : string = - symbolic_value_id_to_string sv.sv_id ^ " : " ^ PT.rty_to_string fmt sv.sv_ty - - let symbolic_value_proj_to_string (fmt : value_formatter) - (sv : V.symbolic_value) (rty : T.rty) : string = - symbolic_value_id_to_string sv.sv_id - ^ " : " - ^ PT.ty_to_string (value_to_rtype_formatter fmt) sv.sv_ty - ^ " <: " - ^ PT.ty_to_string (value_to_rtype_formatter fmt) rty - - (* TODO: it may be a good idea to try to factorize this function with - * typed_avalue_to_string. At some point we had done it, because [typed_value] - * and [typed_avalue] were instances of the same general type [g_typed_value], - * but then we removed this general type because it proved to be a bad idea. *) - let rec typed_value_to_string (fmt : value_formatter) (v : V.typed_value) : - string = - let ty_fmt : PT.etype_formatter = value_to_etype_formatter fmt in - match v.value with - | Concrete cv -> constant_value_to_string cv - | Adt av -> ( - let field_values = - List.map (typed_value_to_string fmt) av.field_values - in - match v.ty with - | T.Adt (T.Tuple, _, _) -> - (* Tuple *) - "(" ^ String.concat ", " field_values ^ ")" - | T.Adt (T.AdtId def_id, _, _) -> - (* "Regular" ADT *) - let adt_ident = - match av.variant_id with - | Some vid -> fmt.adt_variant_to_string def_id vid - | None -> fmt.type_decl_id_to_string def_id - in - if List.length field_values > 0 then - match fmt.adt_field_names def_id av.V.variant_id with - | None -> - let field_values = String.concat ", " field_values in - adt_ident ^ " (" ^ field_values ^ ")" - | Some field_names -> - let field_values = List.combine field_names field_values in - let field_values = - List.map - (fun (field, value) -> field ^ " = " ^ value ^ ";") - field_values - in - let field_values = String.concat " " field_values in - adt_ident ^ " { " ^ field_values ^ " }" - else adt_ident - | T.Adt (T.Assumed aty, _, _) -> ( - (* Assumed type *) - match (aty, field_values) with - | Box, [ bv ] -> "@Box(" ^ bv ^ ")" - | Option, _ -> - if av.variant_id = Some T.option_some_id then - "@Option::Some(" - ^ Collections.List.to_cons_nil field_values - ^ ")" - else if av.variant_id = Some T.option_none_id then ( - assert (field_values = []); - "@Option::None") - else failwith "Unreachable" - | Vec, _ -> "@Vec[" ^ String.concat ", " field_values ^ "]" - | _ -> failwith "Inconsistent value") - | _ -> failwith "Inconsistent typed value") - | Bottom -> "⊥ : " ^ PT.ty_to_string ty_fmt v.ty - | Borrow bc -> borrow_content_to_string fmt bc - | Loan lc -> loan_content_to_string fmt lc - | Symbolic s -> symbolic_value_to_string (value_to_rtype_formatter fmt) s - - and borrow_content_to_string (fmt : value_formatter) (bc : V.borrow_content) : - string = - match bc with - | SharedBorrow (_, bid) -> "⌊shared@" ^ V.BorrowId.to_string bid ^ "⌋" - | MutBorrow (bid, tv) -> - "&mut@" ^ V.BorrowId.to_string bid ^ " (" - ^ typed_value_to_string fmt tv - ^ ")" - | InactivatedMutBorrow (_, bid) -> - "⌊inactivated_mut@" ^ V.BorrowId.to_string bid ^ "⌋" - - and loan_content_to_string (fmt : value_formatter) (lc : V.loan_content) : - string = - match lc with - | SharedLoan (loans, v) -> - let loans = V.BorrowId.Set.to_string None loans in - "@shared_loan(" ^ loans ^ ", " ^ typed_value_to_string fmt v ^ ")" - | MutLoan bid -> "⌊mut@" ^ V.BorrowId.to_string bid ^ "⌋" - - let abstract_shared_borrow_to_string (fmt : value_formatter) - (abs : V.abstract_shared_borrow) : string = - match abs with - | AsbBorrow bid -> V.BorrowId.to_string bid - | AsbProjReborrows (sv, rty) -> - "{" ^ symbolic_value_proj_to_string fmt sv rty ^ "}" - - let abstract_shared_borrows_to_string (fmt : value_formatter) - (abs : V.abstract_shared_borrows) : string = - "{" - ^ String.concat "," (List.map (abstract_shared_borrow_to_string fmt) abs) - ^ "}" - - let rec aproj_to_string (fmt : value_formatter) (pv : V.aproj) : string = - match pv with - | AProjLoans (sv, given_back) -> - let given_back = - if given_back = [] then "" - else - let given_back = List.map snd given_back in - let given_back = List.map (aproj_to_string fmt) given_back in - " (" ^ String.concat "," given_back ^ ") " - in - "⌊" - ^ symbolic_value_to_string (value_to_rtype_formatter fmt) sv - ^ given_back ^ "⌋" - | AProjBorrows (sv, rty) -> - "(" ^ symbolic_value_proj_to_string fmt sv rty ^ ")" - | AEndedProjLoans (_, given_back) -> - if given_back = [] then "_" - else - let given_back = List.map snd given_back in - let given_back = List.map (aproj_to_string fmt) given_back in - "ended_aproj_loans (" ^ String.concat "," given_back ^ ")" - | AEndedProjBorrows _mv -> "_" - | AIgnoredProjBorrows -> "_" - - let rec typed_avalue_to_string (fmt : value_formatter) (v : V.typed_avalue) : - string = - let ty_fmt : PT.rtype_formatter = value_to_rtype_formatter fmt in - match v.value with - | AConcrete cv -> constant_value_to_string cv - | AAdt av -> ( - let field_values = - List.map (typed_avalue_to_string fmt) av.field_values - in - match v.ty with - | T.Adt (T.Tuple, _, _) -> - (* Tuple *) - "(" ^ String.concat ", " field_values ^ ")" - | T.Adt (T.AdtId def_id, _, _) -> - (* "Regular" ADT *) - let adt_ident = - match av.variant_id with - | Some vid -> fmt.adt_variant_to_string def_id vid - | None -> fmt.type_decl_id_to_string def_id - in - if List.length field_values > 0 then - match fmt.adt_field_names def_id av.V.variant_id with - | None -> - let field_values = String.concat ", " field_values in - adt_ident ^ " (" ^ field_values ^ ")" - | Some field_names -> - let field_values = List.combine field_names field_values in - let field_values = - List.map - (fun (field, value) -> field ^ " = " ^ value ^ ";") - field_values - in - let field_values = String.concat " " field_values in - adt_ident ^ " { " ^ field_values ^ " }" - else adt_ident - | T.Adt (T.Assumed aty, _, _) -> ( - (* Assumed type *) - match (aty, field_values) with - | Box, [ bv ] -> "@Box(" ^ bv ^ ")" - | _ -> failwith "Inconsistent value") - | _ -> failwith "Inconsistent typed value") - | ABottom -> "⊥ : " ^ PT.ty_to_string ty_fmt v.ty - | ABorrow bc -> aborrow_content_to_string fmt bc - | ALoan lc -> aloan_content_to_string fmt lc - | ASymbolic s -> aproj_to_string fmt s - | AIgnored -> "_" - - and aloan_content_to_string (fmt : value_formatter) (lc : V.aloan_content) : - string = - match lc with - | AMutLoan (bid, av) -> - "⌊mut@" ^ V.BorrowId.to_string bid ^ ", " - ^ typed_avalue_to_string fmt av - ^ "⌋" - | ASharedLoan (loans, v, av) -> - let loans = V.BorrowId.Set.to_string None loans in - "@shared_loan(" ^ loans ^ ", " - ^ typed_value_to_string fmt v - ^ ", " - ^ typed_avalue_to_string fmt av - ^ ")" - | AEndedMutLoan ml -> - "@ended_mut_loan{" - ^ typed_avalue_to_string fmt ml.child - ^ "; " - ^ typed_avalue_to_string fmt ml.given_back - ^ " }" - | AEndedSharedLoan (v, av) -> - "@ended_shared_loan(" - ^ typed_value_to_string fmt v - ^ ", " - ^ typed_avalue_to_string fmt av - ^ ")" - | AIgnoredMutLoan (bid, av) -> - "@ignored_mut_loan(" ^ V.BorrowId.to_string bid ^ ", " - ^ typed_avalue_to_string fmt av - ^ ")" - | AEndedIgnoredMutLoan ml -> - "@ended_ignored_mut_loan{ " - ^ typed_avalue_to_string fmt ml.child - ^ "; " - ^ typed_avalue_to_string fmt ml.given_back - ^ "}" - | AIgnoredSharedLoan sl -> - "@ignored_shared_loan(" ^ typed_avalue_to_string fmt sl ^ ")" - - and aborrow_content_to_string (fmt : value_formatter) (bc : V.aborrow_content) - : string = - match bc with - | AMutBorrow (_, bid, av) -> - "&mut@" ^ V.BorrowId.to_string bid ^ " (" - ^ typed_avalue_to_string fmt av - ^ ")" - | ASharedBorrow bid -> "⌊shared@" ^ V.BorrowId.to_string bid ^ "⌋" - | AIgnoredMutBorrow (opt_bid, av) -> - "@ignored_mut_borrow(" - ^ option_to_string V.BorrowId.to_string opt_bid - ^ ", " - ^ typed_avalue_to_string fmt av - ^ ")" - | AEndedMutBorrow (_mv, child) -> - "@ended_mut_borrow(" ^ typed_avalue_to_string fmt child ^ ")" - | AEndedIgnoredMutBorrow - { child; given_back_loans_proj; given_back_meta = _ } -> - "@ended_ignored_mut_borrow{ " - ^ typed_avalue_to_string fmt child - ^ "; " - ^ typed_avalue_to_string fmt given_back_loans_proj - ^ ")" - | AEndedSharedBorrow -> "@ended_shared_borrow" - | AProjSharedBorrow sb -> - "@ignored_shared_borrow(" - ^ abstract_shared_borrows_to_string fmt sb - ^ ")" - - let abs_to_string (fmt : value_formatter) (indent : string) - (indent_incr : string) (abs : V.abs) : string = - let indent2 = indent ^ indent_incr in - let avs = - List.map (fun av -> indent2 ^ typed_avalue_to_string fmt av) abs.avalues - in - let avs = String.concat ",\n" avs in - indent ^ "abs@" - ^ V.AbstractionId.to_string abs.abs_id - ^ "{parents=" - ^ V.AbstractionId.Set.to_string None abs.parents - ^ "}" ^ "{regions=" - ^ T.RegionId.Set.to_string None abs.regions - ^ "}" ^ " {\n" ^ avs ^ "\n" ^ indent ^ "}" -end - -module PV = Values (* local module *) - -(** Pretty-printing for contexts *) -module Contexts = struct - let binder_to_string (bv : C.binder) : string = - match bv.name with - | None -> PV.var_id_to_string bv.index - | Some name -> name - - let env_elem_to_string (fmt : PV.value_formatter) (indent : string) - (indent_incr : string) (ev : C.env_elem) : string = - match ev with - | Var (var, tv) -> - let bv = - match var with Some var -> binder_to_string var | None -> "_" - in - indent ^ bv ^ " -> " ^ PV.typed_value_to_string fmt tv ^ " ;" - | Abs abs -> PV.abs_to_string fmt indent indent_incr abs - | Frame -> failwith "Can't print a Frame element" - - let opt_env_elem_to_string (fmt : PV.value_formatter) (indent : string) - (indent_incr : string) (ev : C.env_elem option) : string = - match ev with - | None -> indent ^ "..." - | Some ev -> env_elem_to_string fmt indent indent_incr ev - - (** Filters "dummy" bindings from an environment, to gain space and clarity/ - See [env_to_string]. *) - let filter_env (env : C.env) : C.env_elem option list = - (* We filter: - * - non-dummy bindings which point to ⊥ - * - dummy bindings which don't contain loans nor borrows - * Note that the first case can sometimes be confusing: we may try to improve - * it... - *) - let filter_elem (ev : C.env_elem) : C.env_elem option = - match ev with - | Var (Some _, tv) -> - (* Not a dummy binding: check if the value is ⊥ *) - if VU.is_bottom tv.value then None else Some ev - | Var (None, tv) -> - (* Dummy binding: check if the value contains borrows or loans *) - if VU.borrows_in_value tv || VU.loans_in_value tv then Some ev - else None - | _ -> Some ev - in - let env = List.map filter_elem env in - (* We collapse groups of filtered values - so that we can print one - * single "..." for a whole group of filtered values *) - let rec group_filtered (env : C.env_elem option list) : - C.env_elem option list = - match env with - | [] -> [] - | None :: None :: env -> group_filtered (None :: env) - | x :: env -> x :: group_filtered env - in - group_filtered env - - (** Environments can have a lot of dummy or uninitialized values: [filter] - allows to filter them when printing, replacing groups of such bindings with - "..." to gain space and clarity. - *) - let env_to_string (filter : bool) (fmt : PV.value_formatter) (env : C.env) : - string = - let env = - if filter then filter_env env else List.map (fun ev -> Some ev) env - in - "{\n" - ^ String.concat "\n" - (List.map (fun ev -> opt_env_elem_to_string fmt " " " " ev) env) - ^ "\n}" - - type ctx_formatter = PV.value_formatter - - let ctx_to_etype_formatter (fmt : ctx_formatter) : PT.etype_formatter = - PV.value_to_etype_formatter fmt - - let ctx_to_rtype_formatter (fmt : ctx_formatter) : PT.rtype_formatter = - PV.value_to_rtype_formatter fmt - - let type_ctx_to_adt_variant_to_string_fun - (ctx : T.type_decl T.TypeDeclId.Map.t) : - T.TypeDeclId.id -> T.VariantId.id -> string = - fun def_id variant_id -> - let def = T.TypeDeclId.Map.find def_id ctx in - match def.kind with - | Struct _ | Opaque -> failwith "Unreachable" - | Enum variants -> - let variant = T.VariantId.nth variants variant_id in - name_to_string def.name ^ "::" ^ variant.variant_name - - let type_ctx_to_adt_field_names_fun (ctx : T.type_decl T.TypeDeclId.Map.t) : - T.TypeDeclId.id -> T.VariantId.id option -> string list option = - fun def_id opt_variant_id -> - let def = T.TypeDeclId.Map.find def_id ctx in - let fields = TU.type_decl_get_fields def opt_variant_id in - (* There are two cases: either all the fields have names, or none of them - * has names *) - let has_names = - List.exists (fun f -> Option.is_some f.T.field_name) fields - in - if has_names then - let fields = List.map (fun f -> Option.get f.T.field_name) fields in - Some fields - else None - - let eval_ctx_to_ctx_formatter (ctx : C.eval_ctx) : ctx_formatter = - (* We shouldn't use rvar_to_string *) - let rvar_to_string _r = failwith "Unexpected use of rvar_to_string" in - let r_to_string r = PT.region_id_to_string r in - - let type_var_id_to_string vid = - let v = C.lookup_type_var ctx vid in - v.name - in - let type_decl_id_to_string def_id = - let def = C.ctx_lookup_type_decl ctx def_id in - name_to_string def.name - in - let adt_variant_to_string = - type_ctx_to_adt_variant_to_string_fun ctx.type_context.type_decls - in - let var_id_to_string vid = - let bv = C.ctx_lookup_binder ctx vid in - binder_to_string bv - in - let adt_field_names = - type_ctx_to_adt_field_names_fun ctx.type_context.type_decls - in - { - rvar_to_string; - r_to_string; - type_var_id_to_string; - type_decl_id_to_string; - adt_variant_to_string; - var_id_to_string; - adt_field_names; - } - - (** Split an [env] at every occurrence of [Frame], eliminating those elements. - Also reorders the frames and the values in the frames according to the - following order: - * frames: from the current frame to the first pushed (oldest frame) - * values: from the first pushed (oldest) to the last pushed - *) - let split_env_according_to_frames (env : C.env) : C.env list = - let rec split_aux (frames : C.env list) (curr_frame : C.env) (env : C.env) = - match env with - | [] -> - if List.length curr_frame > 0 then curr_frame :: frames else frames - | Frame :: env' -> split_aux (curr_frame :: frames) [] env' - | ev :: env' -> split_aux frames (ev :: curr_frame) env' - in - let frames = split_aux [] [] env in - frames - - let eval_ctx_to_string (ctx : C.eval_ctx) : string = - let fmt = eval_ctx_to_ctx_formatter ctx in - let ended_regions = T.RegionId.Set.to_string None ctx.ended_regions in - let frames = split_env_according_to_frames ctx.env in - let num_frames = List.length frames in - let frames = - List.mapi - (fun i f -> - let num_bindings = ref 0 in - let num_dummies = ref 0 in - let num_abs = ref 0 in - List.iter - (fun ev -> - match ev with - | C.Var (None, _) -> num_dummies := !num_abs + 1 - | C.Var (Some _, _) -> num_bindings := !num_bindings + 1 - | C.Abs _ -> num_abs := !num_abs + 1 - | _ -> raise (Failure "Unreachable")) - f; - "\n# Frame " ^ string_of_int i ^ ":" ^ "\n- locals: " - ^ string_of_int !num_bindings - ^ "\n- dummy bindings: " ^ string_of_int !num_dummies - ^ "\n- abstractions: " ^ string_of_int !num_abs ^ "\n" - ^ env_to_string true fmt f ^ "\n") - frames - in - "# Ended regions: " ^ ended_regions ^ "\n" ^ "# " ^ string_of_int num_frames - ^ " frame(s)\n" ^ String.concat "" frames -end - -module PC = Contexts (* local module *) - -(** Pretty-printing for contexts (generic functions) *) -module LlbcAst = struct - let var_to_string (var : A.var) : string = - match var.name with - | None -> V.VarId.to_string var.index - | Some name -> name - - type ast_formatter = { - rvar_to_string : T.RegionVarId.id -> string; - r_to_string : T.RegionId.id -> string; - type_var_id_to_string : T.TypeVarId.id -> string; - type_decl_id_to_string : T.TypeDeclId.id -> string; - adt_variant_to_string : T.TypeDeclId.id -> T.VariantId.id -> string; - adt_field_to_string : - T.TypeDeclId.id -> T.VariantId.id option -> T.FieldId.id -> string option; - var_id_to_string : V.VarId.id -> string; - adt_field_names : - T.TypeDeclId.id -> T.VariantId.id option -> string list option; - fun_decl_id_to_string : A.FunDeclId.id -> string; - global_decl_id_to_string : A.GlobalDeclId.id -> string; - } - - let ast_to_ctx_formatter (fmt : ast_formatter) : PC.ctx_formatter = - { - PV.rvar_to_string = fmt.rvar_to_string; - PV.r_to_string = fmt.r_to_string; - PV.type_var_id_to_string = fmt.type_var_id_to_string; - PV.type_decl_id_to_string = fmt.type_decl_id_to_string; - PV.adt_variant_to_string = fmt.adt_variant_to_string; - PV.var_id_to_string = fmt.var_id_to_string; - PV.adt_field_names = fmt.adt_field_names; - } - - let ast_to_value_formatter (fmt : ast_formatter) : PV.value_formatter = - ast_to_ctx_formatter fmt - - let ast_to_etype_formatter (fmt : ast_formatter) : PT.etype_formatter = - { - PT.r_to_string = PT.erased_region_to_string; - PT.type_var_id_to_string = fmt.type_var_id_to_string; - PT.type_decl_id_to_string = fmt.type_decl_id_to_string; - } - - let ast_to_rtype_formatter (fmt : ast_formatter) : PT.rtype_formatter = - { - PT.r_to_string = PT.region_to_string fmt.r_to_string; - PT.type_var_id_to_string = fmt.type_var_id_to_string; - PT.type_decl_id_to_string = fmt.type_decl_id_to_string; - } - - let ast_to_stype_formatter (fmt : ast_formatter) : PT.stype_formatter = - { - PT.r_to_string = PT.region_to_string fmt.rvar_to_string; - PT.type_var_id_to_string = fmt.type_var_id_to_string; - PT.type_decl_id_to_string = fmt.type_decl_id_to_string; - } - - let type_ctx_to_adt_field_to_string_fun (ctx : T.type_decl T.TypeDeclId.Map.t) - : - T.TypeDeclId.id -> T.VariantId.id option -> T.FieldId.id -> string option - = - fun def_id opt_variant_id field_id -> - let def = T.TypeDeclId.Map.find def_id ctx in - let fields = TU.type_decl_get_fields def opt_variant_id in - let field = T.FieldId.nth fields field_id in - field.T.field_name - - let eval_ctx_to_ast_formatter (ctx : C.eval_ctx) : ast_formatter = - let ctx_fmt = PC.eval_ctx_to_ctx_formatter ctx in - let adt_field_to_string = - type_ctx_to_adt_field_to_string_fun ctx.type_context.type_decls - in - let fun_decl_id_to_string def_id = - let def = C.ctx_lookup_fun_decl ctx def_id in - fun_name_to_string def.name - in - let global_decl_id_to_string def_id = - let def = C.ctx_lookup_global_decl ctx def_id in - global_name_to_string def.name - in - { - rvar_to_string = ctx_fmt.PV.rvar_to_string; - r_to_string = ctx_fmt.PV.r_to_string; - type_var_id_to_string = ctx_fmt.PV.type_var_id_to_string; - type_decl_id_to_string = ctx_fmt.PV.type_decl_id_to_string; - adt_variant_to_string = ctx_fmt.PV.adt_variant_to_string; - var_id_to_string = ctx_fmt.PV.var_id_to_string; - adt_field_names = ctx_fmt.PV.adt_field_names; - adt_field_to_string; - fun_decl_id_to_string; - global_decl_id_to_string; - } - - let fun_decl_to_ast_formatter (type_decls : T.type_decl T.TypeDeclId.Map.t) - (fun_decls : A.fun_decl A.FunDeclId.Map.t) - (global_decls : A.global_decl A.GlobalDeclId.Map.t) (fdef : A.fun_decl) : - ast_formatter = - let rvar_to_string r = - let rvar = T.RegionVarId.nth fdef.signature.region_params r in - PT.region_var_to_string rvar - in - let r_to_string r = PT.region_id_to_string r in - - let type_var_id_to_string vid = - let var = T.TypeVarId.nth fdef.signature.type_params vid in - PT.type_var_to_string var - in - let type_decl_id_to_string def_id = - let def = T.TypeDeclId.Map.find def_id type_decls in - name_to_string def.name - in - let adt_variant_to_string = - PC.type_ctx_to_adt_variant_to_string_fun type_decls - in - let var_id_to_string vid = - let var = V.VarId.nth (Option.get fdef.body).locals vid in - var_to_string var - in - let adt_field_names = PC.type_ctx_to_adt_field_names_fun type_decls in - let adt_field_to_string = type_ctx_to_adt_field_to_string_fun type_decls in - let fun_decl_id_to_string def_id = - let def = A.FunDeclId.Map.find def_id fun_decls in - fun_name_to_string def.name - in - let global_decl_id_to_string def_id = - let def = A.GlobalDeclId.Map.find def_id global_decls in - global_name_to_string def.name - in - { - rvar_to_string; - r_to_string; - type_var_id_to_string; - type_decl_id_to_string; - adt_variant_to_string; - var_id_to_string; - adt_field_names; - adt_field_to_string; - fun_decl_id_to_string; - global_decl_id_to_string; - } - - let rec projection_to_string (fmt : ast_formatter) (inside : string) - (p : E.projection) : string = - match p with - | [] -> inside - | pe :: p' -> ( - let s = projection_to_string fmt inside p' in - match pe with - | E.Deref -> "*(" ^ s ^ ")" - | E.DerefBox -> "deref_box(" ^ s ^ ")" - | E.Field (E.ProjOption variant_id, fid) -> - assert (variant_id = T.option_some_id); - assert (fid = T.FieldId.zero); - "(" ^ s ^ " as Option::Some)." ^ T.FieldId.to_string fid - | E.Field (E.ProjTuple _, fid) -> - "(" ^ s ^ ")." ^ T.FieldId.to_string fid - | E.Field (E.ProjAdt (adt_id, opt_variant_id), fid) -> ( - let field_name = - match fmt.adt_field_to_string adt_id opt_variant_id fid with - | Some field_name -> field_name - | None -> T.FieldId.to_string fid - in - match opt_variant_id with - | None -> "(" ^ s ^ ")." ^ field_name - | Some variant_id -> - let variant_name = - fmt.adt_variant_to_string adt_id variant_id - in - "(" ^ s ^ " as " ^ variant_name ^ ")." ^ field_name)) - - let place_to_string (fmt : ast_formatter) (p : E.place) : string = - let var = fmt.var_id_to_string p.E.var_id in - projection_to_string fmt var p.E.projection - - let unop_to_string (unop : E.unop) : string = - match unop with - | E.Not -> "¬" - | E.Neg -> "-" - | E.Cast (src, tgt) -> - "cast<" - ^ PT.integer_type_to_string src - ^ "," - ^ PT.integer_type_to_string tgt - ^ ">" - - let binop_to_string (binop : E.binop) : string = - match binop with - | E.BitXor -> "^" - | E.BitAnd -> "&" - | E.BitOr -> "|" - | E.Eq -> "==" - | E.Lt -> "<" - | E.Le -> "<=" - | E.Ne -> "!=" - | E.Ge -> ">=" - | E.Gt -> ">" - | E.Div -> "/" - | E.Rem -> "%" - | E.Add -> "+" - | E.Sub -> "-" - | E.Mul -> "*" - | E.Shl -> "<<" - | E.Shr -> ">>" - - let operand_to_string (fmt : ast_formatter) (op : E.operand) : string = - match op with - | E.Copy p -> "copy " ^ place_to_string fmt p - | E.Move p -> "move " ^ place_to_string fmt p - | E.Constant (ty, cv) -> - "(" - ^ PV.constant_value_to_string cv - ^ " : " - ^ PT.ety_to_string (ast_to_etype_formatter fmt) ty - ^ ")" - - let rvalue_to_string (fmt : ast_formatter) (rv : E.rvalue) : string = - match rv with - | E.Use op -> operand_to_string fmt op - | E.Ref (p, bk) -> ( - let p = place_to_string fmt p in - match bk with - | E.Shared -> "&" ^ p - | E.Mut -> "&mut " ^ p - | E.TwoPhaseMut -> "&two-phase " ^ p) - | E.UnaryOp (unop, op) -> - unop_to_string unop ^ " " ^ operand_to_string fmt op - | E.BinaryOp (binop, op1, op2) -> - operand_to_string fmt op1 ^ " " ^ binop_to_string binop ^ " " - ^ operand_to_string fmt op2 - | E.Discriminant p -> "discriminant(" ^ place_to_string fmt p ^ ")" - | E.Aggregate (akind, ops) -> ( - let ops = List.map (operand_to_string fmt) ops in - match akind with - | E.AggregatedTuple -> "(" ^ String.concat ", " ops ^ ")" - | E.AggregatedOption (variant_id, _ty) -> - if variant_id == T.option_none_id then ( - assert (ops == []); - "@Option::None") - else if variant_id == T.option_some_id then ( - assert (List.length ops == 1); - let op = List.hd ops in - "@Option::Some(" ^ op ^ ")") - else raise (Failure "Unreachable") - | E.AggregatedAdt (def_id, opt_variant_id, _regions, _types) -> - let adt_name = fmt.type_decl_id_to_string def_id in - let variant_name = - match opt_variant_id with - | None -> adt_name - | Some variant_id -> - adt_name ^ "::" ^ fmt.adt_variant_to_string def_id variant_id - in - let fields = - match fmt.adt_field_names def_id opt_variant_id with - | None -> "(" ^ String.concat ", " ops ^ ")" - | Some field_names -> - let fields = List.combine field_names ops in - let fields = - List.map - (fun (field, value) -> field ^ " = " ^ value ^ ";") - fields - in - let fields = String.concat " " fields in - "{ " ^ fields ^ " }" - in - variant_name ^ " " ^ fields) - - let rec statement_to_string (fmt : ast_formatter) (indent : string) - (indent_incr : string) (st : A.statement) : string = - raw_statement_to_string fmt indent indent_incr st.content - - and raw_statement_to_string (fmt : ast_formatter) (indent : string) - (indent_incr : string) (st : A.raw_statement) : string = - match st with - | A.Assign (p, rv) -> - indent ^ place_to_string fmt p ^ " := " ^ rvalue_to_string fmt rv - | A.AssignGlobal { dst; global } -> - indent ^ fmt.var_id_to_string dst ^ " := global " - ^ fmt.global_decl_id_to_string global - | A.FakeRead p -> indent ^ "fake_read " ^ place_to_string fmt p - | A.SetDiscriminant (p, variant_id) -> - (* TODO: improve this to lookup the variant name by using the def id *) - indent ^ "set_discriminant(" ^ place_to_string fmt p ^ ", " - ^ T.VariantId.to_string variant_id - ^ ")" - | A.Drop p -> indent ^ "drop(" ^ place_to_string fmt p ^ ")" - | A.Assert a -> - let cond = operand_to_string fmt a.A.cond in - if a.A.expected then indent ^ "assert(" ^ cond ^ ")" - else indent ^ "assert(¬" ^ cond ^ ")" - | A.Call call -> - let ty_fmt = ast_to_etype_formatter fmt in - let t_params = - if List.length call.A.type_args > 0 then - "<" - ^ String.concat "," - (List.map (PT.ty_to_string ty_fmt) call.A.type_args) - ^ ">" - else "" - in - let args = List.map (operand_to_string fmt) call.A.args in - let args = "(" ^ String.concat ", " args ^ ")" in - let name_args = - match call.A.func with - | A.Regular fid -> fmt.fun_decl_id_to_string fid ^ t_params - | A.Assumed fid -> ( - match fid with - | A.Replace -> "core::mem::replace" ^ t_params - | A.BoxNew -> "alloc::boxed::Box" ^ t_params ^ "::new" - | A.BoxDeref -> - "core::ops::deref::Deref<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/src/PrintPure.ml b/src/PrintPure.ml deleted file mode 100644 index a9e42f6c..00000000 --- a/src/PrintPure.ml +++ /dev/null @@ -1,594 +0,0 @@ -(** This module defines printing functions for the types defined in Pure.ml *) - -open Pure -open PureUtils - -type type_formatter = { - type_var_id_to_string : TypeVarId.id -> string; - type_decl_id_to_string : TypeDeclId.id -> string; -} - -type value_formatter = { - type_var_id_to_string : TypeVarId.id -> string; - type_decl_id_to_string : TypeDeclId.id -> string; - adt_variant_to_string : TypeDeclId.id -> VariantId.id -> string; - var_id_to_string : VarId.id -> string; - adt_field_names : TypeDeclId.id -> VariantId.id option -> string list option; -} - -let value_to_type_formatter (fmt : value_formatter) : type_formatter = - { - type_var_id_to_string = fmt.type_var_id_to_string; - type_decl_id_to_string = fmt.type_decl_id_to_string; - } - -(* TODO: we need to store which variables we have encountered so far, and - remove [var_id_to_string]. -*) -type ast_formatter = { - type_var_id_to_string : TypeVarId.id -> string; - type_decl_id_to_string : TypeDeclId.id -> string; - adt_variant_to_string : TypeDeclId.id -> VariantId.id -> string; - var_id_to_string : VarId.id -> string; - adt_field_to_string : - TypeDeclId.id -> VariantId.id option -> FieldId.id -> string option; - adt_field_names : TypeDeclId.id -> VariantId.id option -> string list option; - fun_decl_id_to_string : FunDeclId.id -> string; - global_decl_id_to_string : GlobalDeclId.id -> string; -} - -let ast_to_value_formatter (fmt : ast_formatter) : value_formatter = - { - type_var_id_to_string = fmt.type_var_id_to_string; - type_decl_id_to_string = fmt.type_decl_id_to_string; - adt_variant_to_string = fmt.adt_variant_to_string; - var_id_to_string = fmt.var_id_to_string; - adt_field_names = fmt.adt_field_names; - } - -let ast_to_type_formatter (fmt : ast_formatter) : type_formatter = - let fmt = ast_to_value_formatter fmt in - value_to_type_formatter fmt - -let name_to_string = Print.name_to_string -let fun_name_to_string = Print.fun_name_to_string -let global_name_to_string = Print.global_name_to_string -let option_to_string = Print.option_to_string -let type_var_to_string = Print.Types.type_var_to_string -let integer_type_to_string = Print.Types.integer_type_to_string -let scalar_value_to_string = Print.Values.scalar_value_to_string - -let mk_type_formatter (type_decls : T.type_decl TypeDeclId.Map.t) - (type_params : type_var list) : type_formatter = - let type_var_id_to_string vid = - let var = T.TypeVarId.nth type_params vid in - type_var_to_string var - in - let type_decl_id_to_string def_id = - let def = T.TypeDeclId.Map.find def_id type_decls in - name_to_string def.name - in - { type_var_id_to_string; type_decl_id_to_string } - -(* TODO: there is a bit of duplication with Print.fun_decl_to_ast_formatter. - - TODO: use the pure defs as inputs? Note that it is a bit annoying for the - functions (there is a difference between the forward/backward functions...) - while we only need those definitions to lookup proper names for the def ids. -*) -let mk_ast_formatter (type_decls : T.type_decl TypeDeclId.Map.t) - (fun_decls : A.fun_decl FunDeclId.Map.t) - (global_decls : A.global_decl GlobalDeclId.Map.t) - (type_params : type_var list) : ast_formatter = - let type_var_id_to_string vid = - let var = T.TypeVarId.nth type_params vid in - type_var_to_string var - in - let type_decl_id_to_string def_id = - let def = T.TypeDeclId.Map.find def_id type_decls in - name_to_string def.name - in - let adt_variant_to_string = - Print.Contexts.type_ctx_to_adt_variant_to_string_fun type_decls - in - let var_id_to_string vid = - (* TODO: somehow lookup in the context *) - "^" ^ VarId.to_string vid - in - let adt_field_names = - Print.Contexts.type_ctx_to_adt_field_names_fun type_decls - in - let adt_field_to_string = - Print.LlbcAst.type_ctx_to_adt_field_to_string_fun type_decls - in - let fun_decl_id_to_string def_id = - let def = FunDeclId.Map.find def_id fun_decls in - fun_name_to_string def.name - in - let global_decl_id_to_string def_id = - let def = GlobalDeclId.Map.find def_id global_decls in - global_name_to_string def.name - in - { - type_var_id_to_string; - type_decl_id_to_string; - adt_variant_to_string; - var_id_to_string; - adt_field_names; - adt_field_to_string; - fun_decl_id_to_string; - global_decl_id_to_string; - } - -let type_id_to_string (fmt : type_formatter) (id : type_id) : string = - match id with - | AdtId id -> fmt.type_decl_id_to_string id - | Tuple -> "" - | Assumed aty -> ( - match aty with - | State -> "State" - | Result -> "Result" - | Option -> "Option" - | Vec -> "Vec") - -let rec ty_to_string (fmt : type_formatter) (ty : ty) : string = - match ty with - | Adt (id, tys) -> ( - let tys = List.map (ty_to_string fmt) tys in - match id with - | Tuple -> "(" ^ String.concat " * " tys ^ ")" - | AdtId _ | Assumed _ -> - let tys = if tys = [] then "" else " " ^ String.concat " " tys in - type_id_to_string fmt id ^ tys) - | TypeVar tv -> fmt.type_var_id_to_string tv - | Bool -> "bool" - | Char -> "char" - | Integer int_ty -> integer_type_to_string int_ty - | Str -> "str" - | Array aty -> "[" ^ ty_to_string fmt aty ^ "; ?]" - | Slice sty -> "[" ^ ty_to_string fmt sty ^ "]" - | Arrow (arg_ty, ret_ty) -> - ty_to_string fmt arg_ty ^ " -> " ^ ty_to_string fmt ret_ty - -let field_to_string fmt (f : field) : string = - match f.field_name with - | None -> ty_to_string fmt f.field_ty - | Some field_name -> field_name ^ " : " ^ ty_to_string fmt f.field_ty - -let variant_to_string fmt (v : variant) : string = - v.variant_name ^ "(" - ^ String.concat ", " (List.map (field_to_string fmt) v.fields) - ^ ")" - -let type_decl_to_string (fmt : type_formatter) (def : type_decl) : string = - let types = def.type_params in - let name = name_to_string def.name in - let params = - if types = [] then "" - else " " ^ String.concat " " (List.map type_var_to_string types) - in - match def.kind with - | Struct fields -> - if List.length fields > 0 then - let fields = - String.concat "," - (List.map (fun f -> "\n " ^ field_to_string fmt f) fields) - in - "struct " ^ name ^ params ^ "{" ^ fields ^ "}" - else "struct " ^ name ^ params ^ "{}" - | Enum variants -> - let variants = - List.map (fun v -> "| " ^ variant_to_string fmt v) variants - in - let variants = String.concat "\n" variants in - "enum " ^ name ^ params ^ " =\n" ^ variants - | Opaque -> "opaque type " ^ name ^ params - -let var_to_varname (v : var) : string = - match v.basename with - | Some name -> name ^ "^" ^ VarId.to_string v.id - | None -> "^" ^ VarId.to_string v.id - -let var_to_string (fmt : type_formatter) (v : var) : string = - let varname = var_to_varname v in - "(" ^ varname ^ " : " ^ ty_to_string fmt v.ty ^ ")" - -let rec mprojection_to_string (fmt : ast_formatter) (inside : string) - (p : mprojection) : string = - match p with - | [] -> inside - | pe :: p' -> ( - let s = mprojection_to_string fmt inside p' in - match pe.pkind with - | E.ProjOption variant_id -> - assert (variant_id = T.option_some_id); - assert (pe.field_id = T.FieldId.zero); - "(" ^ s ^ "as Option::Some)." ^ T.FieldId.to_string pe.field_id - | E.ProjTuple _ -> "(" ^ s ^ ")." ^ T.FieldId.to_string pe.field_id - | E.ProjAdt (adt_id, opt_variant_id) -> ( - let field_name = - match fmt.adt_field_to_string adt_id opt_variant_id pe.field_id with - | Some field_name -> field_name - | None -> T.FieldId.to_string pe.field_id - in - match opt_variant_id with - | None -> "(" ^ s ^ ")." ^ field_name - | Some variant_id -> - let variant_name = fmt.adt_variant_to_string adt_id variant_id in - "(" ^ s ^ " as " ^ variant_name ^ ")." ^ field_name)) - -let mplace_to_string (fmt : ast_formatter) (p : mplace) : string = - let name = match p.name with None -> "" | Some name -> name in - (* We add the "llbc" suffix to the variable index, because meta-places - * use indices of the variables in the original LLBC program, while - * regular places use indices for the pure variables: we want to make - * this explicit, otherwise it is confusing. *) - let name = name ^ "^" ^ V.VarId.to_string p.var_id ^ "llbc" in - mprojection_to_string fmt name p.projection - -let adt_variant_to_string (fmt : value_formatter) (adt_id : type_id) - (variant_id : VariantId.id option) : string = - match adt_id with - | Tuple -> "Tuple" - | AdtId def_id -> ( - (* "Regular" ADT *) - match variant_id with - | Some vid -> fmt.adt_variant_to_string def_id vid - | None -> fmt.type_decl_id_to_string def_id) - | Assumed aty -> ( - (* Assumed type *) - match aty with - | State -> - (* The [State] type is opaque: we can't get there *) - raise (Failure "Unreachable") - | Result -> - let variant_id = Option.get variant_id in - if variant_id = result_return_id then "@Result::Return" - else if variant_id = result_fail_id then "@Result::Fail" - else - raise (Failure "Unreachable: improper variant id for result type") - | Option -> - let variant_id = Option.get variant_id in - if variant_id = option_some_id then "@Option::Some " - else if variant_id = option_none_id then "@Option::None" - else - raise (Failure "Unreachable: improper variant id for result type") - | Vec -> - assert (variant_id = None); - "Vec") - -let adt_field_to_string (fmt : value_formatter) (adt_id : type_id) - (field_id : FieldId.id) : string = - match adt_id with - | Tuple -> - raise (Failure "Unreachable") - (* Tuples don't use the opaque field id for the field indices, but [int] *) - | AdtId def_id -> ( - (* "Regular" ADT *) - let fields = fmt.adt_field_names def_id None in - match fields with - | None -> FieldId.to_string field_id - | Some fields -> FieldId.nth fields field_id) - | Assumed aty -> ( - (* Assumed type *) - match aty with - | State | Vec -> - (* Opaque types: we can't get there *) - raise (Failure "Unreachable") - | Result | Option -> - (* Enumerations: we can't get there *) - raise (Failure "Unreachable")) - -(** TODO: we don't need a general function anymore (it is now only used for - patterns (i.e., patterns) - *) -let adt_g_value_to_string (fmt : value_formatter) - (value_to_string : 'v -> string) (variant_id : VariantId.id option) - (field_values : 'v list) (ty : ty) : string = - let field_values = List.map value_to_string field_values in - match ty with - | Adt (Tuple, _) -> - (* Tuple *) - "(" ^ String.concat ", " field_values ^ ")" - | Adt (AdtId def_id, _) -> - (* "Regular" ADT *) - let adt_ident = - match variant_id with - | Some vid -> fmt.adt_variant_to_string def_id vid - | None -> fmt.type_decl_id_to_string def_id - in - if field_values <> [] then - match fmt.adt_field_names def_id variant_id with - | None -> - let field_values = String.concat ", " field_values in - adt_ident ^ " (" ^ field_values ^ ")" - | Some field_names -> - let field_values = List.combine field_names field_values in - let field_values = - List.map - (fun (field, value) -> field ^ " = " ^ value ^ ";") - field_values - in - let field_values = String.concat " " field_values in - adt_ident ^ " { " ^ field_values ^ " }" - else adt_ident - | Adt (Assumed aty, _) -> ( - (* Assumed type *) - match aty with - | State -> - (* The [State] type is opaque: we can't get there *) - raise (Failure "Unreachable") - | Result -> - let variant_id = Option.get variant_id in - if variant_id = result_return_id then - match field_values with - | [ v ] -> "@Result::Return " ^ v - | _ -> raise (Failure "Result::Return takes exactly one value") - else if variant_id = result_fail_id then ( - assert (field_values = []); - "@Result::Fail") - else - raise (Failure "Unreachable: improper variant id for result type") - | Option -> - let variant_id = Option.get variant_id in - if variant_id = option_some_id then - match field_values with - | [ v ] -> "@Option::Some " ^ v - | _ -> raise (Failure "Option::Some takes exactly one value") - else if variant_id = option_none_id then ( - assert (field_values = []); - "@Option::None") - else - raise (Failure "Unreachable: improper variant id for result type") - | Vec -> - assert (variant_id = None); - let field_values = - List.mapi (fun i v -> string_of_int i ^ " -> " ^ v) field_values - in - "Vec [" ^ String.concat "; " field_values ^ "]") - | _ -> - let fmt = value_to_type_formatter fmt in - raise - (Failure - ("Inconsistently typed value: expected ADT type but found:" - ^ "\n- ty: " ^ ty_to_string fmt ty ^ "\n- variant_id: " - ^ Print.option_to_string VariantId.to_string variant_id)) - -let rec typed_pattern_to_string (fmt : ast_formatter) (v : typed_pattern) : - string = - match v.value with - | PatConcrete cv -> Print.Values.constant_value_to_string cv - | PatVar (v, None) -> var_to_string (ast_to_type_formatter fmt) v - | PatVar (v, Some mp) -> - let mp = "[@mplace=" ^ mplace_to_string fmt mp ^ "]" in - "(" ^ var_to_varname v ^ " " ^ mp ^ " : " - ^ ty_to_string (ast_to_type_formatter fmt) v.ty - ^ ")" - | PatDummy -> "_" - | PatAdt av -> - adt_g_value_to_string - (ast_to_value_formatter fmt) - (typed_pattern_to_string fmt) - av.variant_id av.field_values v.ty - -let fun_sig_to_string (fmt : ast_formatter) (sg : fun_sig) : string = - let ty_fmt = ast_to_type_formatter fmt in - let type_params = List.map type_var_to_string sg.type_params in - let inputs = List.map (ty_to_string ty_fmt) sg.inputs in - let output = ty_to_string ty_fmt sg.output in - let all_types = List.concat [ type_params; inputs; [ output ] ] in - String.concat " -> " all_types - -let inst_fun_sig_to_string (fmt : ast_formatter) (sg : inst_fun_sig) : string = - let ty_fmt = ast_to_type_formatter fmt in - let inputs = List.map (ty_to_string ty_fmt) sg.inputs in - let output = ty_to_string ty_fmt sg.output in - let all_types = List.append inputs [ output ] in - String.concat " -> " all_types - -let regular_fun_id_to_string (fmt : ast_formatter) (fun_id : A.fun_id) : string - = - match fun_id with - | A.Regular fid -> fmt.fun_decl_id_to_string fid - | A.Assumed fid -> ( - match fid with - | A.Replace -> "core::mem::replace" - | A.BoxNew -> "alloc::boxed::Box::new" - | A.BoxDeref -> "core::ops::deref::Deref::deref" - | A.BoxDerefMut -> "core::ops::deref::DerefMut::deref_mut" - | A.BoxFree -> "alloc::alloc::box_free" - | A.VecNew -> "alloc::vec::Vec::new" - | A.VecPush -> "alloc::vec::Vec::push" - | A.VecInsert -> "alloc::vec::Vec::insert" - | A.VecLen -> "alloc::vec::Vec::len" - | A.VecIndex -> "core::ops::index::Index<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/src/Pure.ml b/src/Pure.ml deleted file mode 100644 index 77265f75..00000000 --- a/src/Pure.ml +++ /dev/null @@ -1,581 +0,0 @@ -open Identifiers -open Names -module T = Types -module V = Values -module E = Expressions -module A = LlbcAst -module TypeDeclId = T.TypeDeclId -module TypeVarId = T.TypeVarId -module RegionGroupId = T.RegionGroupId -module VariantId = T.VariantId -module FieldId = T.FieldId -module SymbolicValueId = V.SymbolicValueId -module FunDeclId = A.FunDeclId -module GlobalDeclId = A.GlobalDeclId - -(** We give an identifier to every phase of the synthesis (forward, backward - for group of regions 0, etc.) *) -module SynthPhaseId = IdGen () - -(** Pay attention to the fact that we also define a {!Values.VarId} module in Values *) -module VarId = IdGen () - -type integer_type = T.integer_type [@@deriving show, ord] - -(** The assumed types for the pure AST. - - In comparison with LLBC: - - we removed [Box] (because it is translated as the identity: [Box T == T]) - - we added: - - [Result]: the type used in the error monad. This allows us to have a - unified treatment of expressions (especially when we have to unfold the - monadic binds) - - [State]: the type of the state, when using state-error monads. Note that - this state is opaque to Aeneas (the user can define it, or leave it as - assumed) - *) -type assumed_ty = State | Result | Vec | Option [@@deriving show, ord] - -(* TODO: we should never directly manipulate [Return] and [Fail], but rather - * the monadic functions [return] and [fail] (makes treatment of error and - * state-error monads more uniform) *) -let result_return_id = VariantId.of_int 0 -let result_fail_id = VariantId.of_int 1 -let option_some_id = T.option_some_id -let option_none_id = T.option_none_id - -type type_id = AdtId of TypeDeclId.id | Tuple | Assumed of assumed_ty -[@@deriving show, ord] - -(** Ancestor for iter visitor for [ty] *) -class ['self] iter_ty_base = - object (_self : 'self) - inherit [_] VisitorsRuntime.iter - method visit_id : 'env -> TypeVarId.id -> unit = fun _ _ -> () - method visit_type_id : 'env -> type_id -> unit = fun _ _ -> () - method visit_integer_type : 'env -> integer_type -> unit = fun _ _ -> () - end - -(** Ancestor for map visitor for [ty] *) -class ['self] map_ty_base = - object (_self : 'self) - inherit [_] VisitorsRuntime.map - method visit_id : 'env -> TypeVarId.id -> TypeVarId.id = fun _ id -> id - method visit_type_id : 'env -> type_id -> type_id = fun _ id -> id - - method visit_integer_type : 'env -> integer_type -> integer_type = - fun _ ity -> ity - end - -type ty = - | Adt of type_id * ty list - (** {!Adt} encodes ADTs and tuples and assumed types. - - TODO: what about the ended regions? (ADTs may be parameterized - with several region variables. When giving back an ADT value, we may - be able to only give back part of the ADT. We need a way to encode - such "partial" ADTs. - *) - | TypeVar of TypeVarId.id - | Bool - | Char - | Integer of integer_type - | Str - | Array of ty (* TODO: this should be an assumed type?... *) - | Slice of ty (* TODO: this should be an assumed type?... *) - | Arrow of ty * ty -[@@deriving - show, - visitors - { - name = "iter_ty"; - variety = "iter"; - ancestors = [ "iter_ty_base" ]; - nude = true (* Don't inherit {!VisitorsRuntime.iter} *); - concrete = true; - polymorphic = false; - }, - visitors - { - name = "map_ty"; - variety = "map"; - ancestors = [ "map_ty_base" ]; - nude = true (* Don't inherit {!VisitorsRuntime.iter} *); - concrete = true; - polymorphic = false; - }] - -type field = { field_name : string option; field_ty : ty } [@@deriving show] -type variant = { variant_name : string; fields : field list } [@@deriving show] - -type type_decl_kind = Struct of field list | Enum of variant list | Opaque -[@@deriving show] - -type type_var = T.type_var [@@deriving show] - -type type_decl = { - def_id : TypeDeclId.id; - name : name; - type_params : type_var list; - kind : type_decl_kind; -} -[@@deriving show] - -type scalar_value = V.scalar_value [@@deriving show] -type constant_value = V.constant_value [@@deriving show] - -(** Because we introduce a lot of temporary variables, the list of variables - is not fixed: we thus must carry all its information with the variable - itself. - *) -type var = { - id : VarId.id; - basename : string option; - (** The "basename" is used to generate a meaningful name for the variable - (by potentially adding an index to uniquely identify it). - *) - ty : ty; -} -[@@deriving show] - -(* TODO: we might want to redefine field_proj_kind here, to prevent field accesses - * on enumerations. - * Also: tuples... - * Rmk: projections are actually only used as meta-data. - * *) -type mprojection_elem = { pkind : E.field_proj_kind; field_id : FieldId.id } -[@@deriving show] - -type mprojection = mprojection_elem list [@@deriving show] - -(** "Meta" place. - - Meta-data retrieved from the symbolic execution, which gives provenance - information about the values. We use this to generate names for the variables - we introduce. - *) -type mplace = { - var_id : V.VarId.id; - name : string option; - projection : mprojection; -} -[@@deriving show] - -type variant_id = VariantId.id [@@deriving show] - -(** Ancestor for [iter_pat_var_or_dummy] visitor *) -class ['self] iter_value_base = - object (_self : 'self) - inherit [_] VisitorsRuntime.iter - method visit_constant_value : 'env -> constant_value -> unit = fun _ _ -> () - method visit_var : 'env -> var -> unit = fun _ _ -> () - method visit_mplace : 'env -> mplace -> unit = fun _ _ -> () - method visit_ty : 'env -> ty -> unit = fun _ _ -> () - method visit_variant_id : 'env -> variant_id -> unit = fun _ _ -> () - end - -(** Ancestor for [map_typed_rvalue] visitor *) -class ['self] map_value_base = - object (_self : 'self) - inherit [_] VisitorsRuntime.map - - method visit_constant_value : 'env -> constant_value -> constant_value = - fun _ x -> x - - method visit_var : 'env -> var -> var = fun _ x -> x - method visit_mplace : 'env -> mplace -> mplace = fun _ x -> x - method visit_ty : 'env -> ty -> ty = fun _ x -> x - method visit_variant_id : 'env -> variant_id -> variant_id = fun _ x -> x - end - -(** Ancestor for [reduce_typed_rvalue] visitor *) -class virtual ['self] reduce_value_base = - object (self : 'self) - inherit [_] VisitorsRuntime.reduce - - method visit_constant_value : 'env -> constant_value -> 'a = - fun _ _ -> self#zero - - method visit_var : 'env -> var -> 'a = fun _ _ -> self#zero - method visit_mplace : 'env -> mplace -> 'a = fun _ _ -> self#zero - method visit_ty : 'env -> ty -> 'a = fun _ _ -> self#zero - method visit_variant_id : 'env -> variant_id -> 'a = fun _ _ -> self#zero - end - -(** Ancestor for [mapreduce_typed_rvalue] visitor *) -class virtual ['self] mapreduce_value_base = - object (self : 'self) - inherit [_] VisitorsRuntime.mapreduce - - method visit_constant_value : 'env -> constant_value -> constant_value * 'a - = - fun _ x -> (x, self#zero) - - method visit_var : 'env -> var -> var * 'a = fun _ x -> (x, self#zero) - - method visit_mplace : 'env -> mplace -> mplace * 'a = - fun _ x -> (x, self#zero) - - method visit_ty : 'env -> ty -> ty * 'a = fun _ x -> (x, self#zero) - - method visit_variant_id : 'env -> variant_id -> variant_id * 'a = - fun _ x -> (x, self#zero) - end - -(** A pattern (which appears on the left of assignments, in matches, etc.). *) -type pattern = - | PatConcrete of constant_value - (** {!PatConcrete} is necessary because we merge the switches over integer - values and the matches over enumerations *) - | PatVar of var * mplace option - | PatDummy (** Ignored value: [_]. *) - | PatAdt of adt_pattern - -and adt_pattern = { - variant_id : variant_id option; - field_values : typed_pattern list; -} - -and typed_pattern = { value : pattern; ty : ty } -[@@deriving - show, - visitors - { - name = "iter_typed_pattern"; - variety = "iter"; - ancestors = [ "iter_value_base" ]; - nude = true (* Don't inherit {!VisitorsRuntime.iter} *); - concrete = true; - polymorphic = false; - }, - visitors - { - name = "map_typed_pattern"; - variety = "map"; - ancestors = [ "map_value_base" ]; - nude = true (* Don't inherit {!VisitorsRuntime.iter} *); - concrete = true; - polymorphic = false; - }, - visitors - { - name = "reduce_typed_pattern"; - variety = "reduce"; - ancestors = [ "reduce_value_base" ]; - nude = true (* Don't inherit {!VisitorsRuntime.iter} *); - polymorphic = false; - }, - visitors - { - name = "mapreduce_typed_pattern"; - variety = "mapreduce"; - ancestors = [ "mapreduce_value_base" ]; - nude = true (* Don't inherit {!VisitorsRuntime.iter} *); - polymorphic = false; - }] - -type unop = Not | Neg of integer_type | Cast of integer_type * integer_type -[@@deriving show, ord] - -type fun_id = - | Regular of A.fun_id * T.RegionGroupId.id option - (** Backward id: [Some] if the function is a backward function, [None] - if it is a forward function. - - TODO: we need to redefine A.fun_id here, to add [fail] and - [return] (important to get a unified treatment of the state-error - monad). For now, when using the state-error monad: extraction - works only if we unfold all the monadic let-bindings, and we - then replace the content of the occurrences of [Return] to also - return the state (which is really super ugly). - *) - | Unop of unop - | Binop of E.binop * integer_type -[@@deriving show, ord] - -(** An identifier for an ADT constructor *) -type adt_cons_id = { adt_id : type_id; variant_id : variant_id option } -[@@deriving show] - -(** Projection - For now we don't support projection of tuple fields - (because not all the backends have syntax for this). - *) -type projection = { adt_id : type_id; field_id : FieldId.id } [@@deriving show] - -type qualif_id = - | Func of fun_id - | Global of GlobalDeclId.id - | AdtCons of adt_cons_id (** A function or ADT constructor identifier *) - | Proj of projection (** Field projector *) -[@@deriving show] - -(** An instantiated qualified. - - Note that for now we have a clear separation between types and expressions, - which explains why we have the [type_params] field: a function or ADT - constructor is always fully instantiated. - *) -type qualif = { id : qualif_id; type_args : ty list } [@@deriving show] - -type var_id = VarId.id [@@deriving show] - -(** Ancestor for [iter_expression] visitor *) -class ['self] iter_expression_base = - object (_self : 'self) - inherit [_] iter_typed_pattern - method visit_integer_type : 'env -> integer_type -> unit = fun _ _ -> () - method visit_var_id : 'env -> var_id -> unit = fun _ _ -> () - method visit_qualif : 'env -> qualif -> unit = fun _ _ -> () - end - -(** Ancestor for [map_expression] visitor *) -class ['self] map_expression_base = - object (_self : 'self) - inherit [_] map_typed_pattern - - method visit_integer_type : 'env -> integer_type -> integer_type = - fun _ x -> x - - method visit_var_id : 'env -> var_id -> var_id = fun _ x -> x - method visit_qualif : 'env -> qualif -> qualif = fun _ x -> x - end - -(** Ancestor for [reduce_expression] visitor *) -class virtual ['self] reduce_expression_base = - object (self : 'self) - inherit [_] reduce_typed_pattern - - method visit_integer_type : 'env -> integer_type -> 'a = - fun _ _ -> self#zero - - method visit_var_id : 'env -> var_id -> 'a = fun _ _ -> self#zero - method visit_qualif : 'env -> qualif -> 'a = fun _ _ -> self#zero - end - -(** Ancestor for [mapreduce_expression] visitor *) -class virtual ['self] mapreduce_expression_base = - object (self : 'self) - inherit [_] mapreduce_typed_pattern - - method visit_integer_type : 'env -> integer_type -> integer_type * 'a = - fun _ x -> (x, self#zero) - - method visit_var_id : 'env -> var_id -> var_id * 'a = - fun _ x -> (x, self#zero) - - method visit_qualif : 'env -> qualif -> qualif * 'a = - fun _ x -> (x, self#zero) - end - -(** **Rk.:** here, {!expression} is not at all equivalent to the expressions - used in LLBC. They are lambda-calculus expressions, and are thus actually - more general than the LLBC statements, in a sense. - *) -type expression = - | Var of var_id (** a variable *) - | Const of constant_value - | App of texpression * texpression - (** Application of a function to an argument. - - The function calls are still quite structured. - Change that?... We might want to have a "normal" lambda calculus - app (with head and argument): this would allow us to replace some - field accesses with calls to projectors over fields (when there - are clashes of field names, some provers like F* get pretty bad...) - *) - | Abs of typed_pattern * texpression (** Lambda abstraction: [fun x -> e] *) - | Qualif of qualif (** A top-level qualifier *) - | Let of bool * typed_pattern * texpression * texpression - (** Let binding. - - TODO: the boolean should be replaced by an enum: sometimes we use - the error-monad, sometimes we use the state-error monad (and we - do this an a per-function basis! For instance, arithmetic functions - are always in the error monad). - - The boolean controls whether the let is monadic or not. - For instance, in F*: - - non-monadic: [let x = ... in ...] - - monadic: [x <-- ...; ...] - - Note that we are quite general for the left-value on purpose; this - is used in several situations: - - 1. When deconstructing a tuple: - {[ - let (x, y) = p in ... - ]} - (not all languages have syntax like [p.0], [p.1]... and it is more - readable anyway). - - 2. When expanding an enumeration with one variant. - In this case, {!Let} has to be understood as: - {[ - let Cons x tl = ls in - ... - ]} - - Note that later, depending on the language we extract to, we can - eventually update it to something like this (for F*, for instance): - {[ - let x = Cons?.v ls in - let tl = Cons?.tl ls in - ... - ]} - *) - | Switch of texpression * switch_body - | Meta of (meta[@opaque]) * texpression (** Meta-information *) - -and switch_body = If of texpression * texpression | Match of match_branch list -and match_branch = { pat : typed_pattern; branch : texpression } -and texpression = { e : expression; ty : ty } - -(** Meta-value (converted to an expression). It is important that the content - is opaque. - - TODO: is it possible to mark the whole mvalue type as opaque? - *) -and mvalue = (texpression[@opaque]) - -and meta = - | Assignment of mplace * mvalue * mplace option - (** Meta-information stored in the AST. - - The first mplace stores the destination. - The mvalue stores the value which is put in the destination - The second (optional) mplace stores the origin. - *) - | MPlace of mplace (** Meta-information about the origin of a value *) -[@@deriving - show, - visitors - { - name = "iter_expression"; - variety = "iter"; - ancestors = [ "iter_expression_base" ]; - nude = true (* Don't inherit {!VisitorsRuntime.iter} *); - concrete = true; - }, - visitors - { - name = "map_expression"; - variety = "map"; - ancestors = [ "map_expression_base" ]; - nude = true (* Don't inherit {!VisitorsRuntime.iter} *); - concrete = true; - }, - visitors - { - name = "reduce_expression"; - variety = "reduce"; - ancestors = [ "reduce_expression_base" ]; - nude = true (* Don't inherit {!VisitorsRuntime.iter} *); - }, - visitors - { - name = "mapreduce_expression"; - variety = "mapreduce"; - ancestors = [ "mapreduce_expression_base" ]; - nude = true (* Don't inherit {!VisitorsRuntime.iter} *); - }] - -(** Information about the "effect" of a function *) -type fun_effect_info = { - input_state : bool; (** [true] if the function takes a state as input *) - output_state : bool; - (** [true] if the function outputs a state (it then lives - in a state monad) *) - can_fail : bool; (** [true] if the return type is a [result] *) -} - -(** Meta information about a function signature *) -type fun_sig_info = { - num_fwd_inputs : int; - (** The number of input types for forward computation *) - num_back_inputs : int option; - (** The number of additional inputs for the backward computation (if pertinent) *) - effect_info : fun_effect_info; -} - -(** A function signature. - - We have the following cases: - - forward function: - [in_ty0 -> ... -> in_tyn -> out_ty] (* pure function *) - `in_ty0 -> ... -> in_tyn -> result out_ty` (* error-monad *) - `in_ty0 -> ... -> in_tyn -> state -> result (state & out_ty)` (* state-error *) - - backward function: - `in_ty0 -> ... -> in_tyn -> back_in0 -> ... back_inm -> (back_out0 & ... & back_outp)` (* pure function *) - `in_ty0 -> ... -> in_tyn -> back_in0 -> ... back_inm -> - result (back_out0 & ... & back_outp)` (* error-monad *) - `in_ty0 -> ... -> in_tyn -> state -> back_in0 -> ... back_inm -> - result (back_out0 & ... & back_outp)` (* state-error *) - - Note that a backward function never returns (i.e., updates) a state: only - forward functions do so. Also, the state input parameter is *betwee* - the forward inputs and the backward inputs. - - The function's type should be given by `mk_arrows sig.inputs sig.output`. - We provide additional meta-information: - - we divide between forward inputs and backward inputs (i.e., inputs specific - to the forward functions, and additional inputs necessary if the signature is - for a backward function) - - we have booleans to give us the fact that the function takes a state as - input, or can fail, etc. without having to inspect the signature - - etc. - *) -type fun_sig = { - type_params : type_var list; - inputs : ty list; - output : ty; - doutputs : ty list; - (** The "decomposed" list of outputs. - - In case of a forward function, the list has length = 1, for the - type of the returned value. - - In case of backward function, the list contains all the types of - all the given back values (there is at most one type per forward - input argument). - - Ex.: - {[ - fn choose<'a, T>(b : bool, x : &'a mut T, y : &'a mut T) -> &'a mut T; - ]} - Decomposed outputs: - - forward function: [T] - - backward function: [T; T] (for "x" and "y") - - *) - info : fun_sig_info; (** Additional information *) -} - -(** An instantiated function signature. See {!fun_sig} *) -type inst_fun_sig = { - inputs : ty list; - output : ty; - doutputs : ty list; - info : fun_sig_info; -} - -type fun_body = { - inputs : var list; - inputs_lvs : typed_pattern list; - (** The inputs seen as patterns. Allows to make transformations, for example - to replace unused variables by [_] *) - body : texpression; -} - -type fun_decl = { - def_id : FunDeclId.id; - back_id : T.RegionGroupId.id option; - basename : fun_name; - (** The "base" name of the function. - - The base name is the original name of the Rust function. We add suffixes - (to identify the forward/backward functions) later. - *) - signature : fun_sig; - is_global_decl_body : bool; - body : fun_body option; -} diff --git a/src/PureMicroPasses.ml b/src/PureMicroPasses.ml deleted file mode 100644 index 3edae38a..00000000 --- a/src/PureMicroPasses.ml +++ /dev/null @@ -1,1375 +0,0 @@ -(** The following module defines micro-passes which operate on the pure AST *) - -open Pure -open PureUtils -open TranslateCore -module V = Values - -(** The local logger *) -let log = L.pure_micro_passes_log - -(** A configuration to control the application of the passes *) -type config = { - decompose_monadic_let_bindings : bool; - (** Some provers like F* don't support the decomposition of return values - in monadic let-bindings: - {[ - // NOT supported in F* - let (x, y) <-- f (); - ... - ]} - - In such situations, we might want to introduce an intermediate - assignment: - {[ - let tmp <-- f (); - let (x, y) = tmp in - ... - ]} - *) - unfold_monadic_let_bindings : bool; - (** Controls the unfolding of monadic let-bindings to explicit matches: - - [y <-- f x; ...] - - becomes: - - [match f x with | Failure -> Failure | Return y -> ...] - - - This is useful when extracting to F*: the support for monadic - definitions is not super powerful. - Note that when {!field:unfold_monadic_let_bindings} is true, setting - {!field:decompose_monadic_let_bindings} to true and only makes the code - more verbose. - *) - filter_useless_monadic_calls : bool; - (** Controls whether we try to filter the calls to monadic functions - (which can fail) when their outputs are not used. - - See the comments for {!expression_contains_child_call_in_all_paths} - for additional explanations. - - TODO: rename to {!filter_useless_monadic_calls} - *) - filter_useless_functions : bool; - (** If {!filter_useless_monadic_calls} is activated, some functions - become useless: if this option is true, we don't extract them. - - The calls to functions which always get filtered are: - - the forward functions with unit return value - - the backward functions which don't output anything (backward - functions coming from rust functions with no mutable borrows - as input values - note that if a function doesn't take mutable - borrows as inputs, it can't return mutable borrows; we actually - dynamically check for that). - *) -} - -(** Small utility. - - We sometimes have to insert new fresh variables in a function body, in which - case we need to make their indices greater than the indices of all the variables - in the body. - TODO: things would be simpler if we used a better representation of the - variables indices... - *) -let get_body_min_var_counter (body : fun_body) : VarId.generator = - (* Find the max id in the input variables - some of them may have been - * filtered from the body *) - let min_input_id = - List.fold_left - (fun id (var : var) -> VarId.max id var.id) - VarId.zero body.inputs - in - let obj = - object - inherit [_] reduce_expression - method zero _ = min_input_id - method plus id0 id1 _ = VarId.max (id0 ()) (id1 ()) - (* Get the maximum *) - - (** For the patterns *) - method! visit_var _ v _ = v.id - - (** For the rvalues *) - method! visit_Var _ vid _ = vid - end - in - (* Find the max counter in the body *) - let id = obj#visit_expression () body.body.e () in - VarId.generator_from_incr_id id - -(** "pretty-name context": see [compute_pretty_names] *) -type pn_ctx = { - pure_vars : string VarId.Map.t; - (** Information about the pure variables used in the synthesized program *) - llbc_vars : string V.VarId.Map.t; - (** Information about the LLBC variables used in the original program *) -} - -(** This function computes pretty names for the variables in the pure AST. It - relies on the "meta"-place information in the AST to generate naming - constraints, and then uses those to compute the names. - - The way it works is as follows: - - we only modify the names of the unnamed variables - - whenever we see an rvalue/pattern which is exactly an unnamed variable, - and this value is linked to some meta-place information which contains - a name and an empty path, we consider we should use this name - - we try to propagate naming constraints on the pure variables use in the - synthesized programs, and also on the LLBC variables from the original - program (information about the LLBC variables is stored in the meta-places) - - - Something important is that, for every variable we find, the name of this - variable can be influenced by the information we find *below* in the AST. - - For instance, the following situations happen: - - - let's say we evaluate: - {[ - match (ls : List<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/src/PureToExtract.ml b/src/PureToExtract.ml deleted file mode 100644 index 77c3afd4..00000000 --- a/src/PureToExtract.ml +++ /dev/null @@ -1,723 +0,0 @@ -(** This module is used to extract the pure ASTs to various theorem provers. - It defines utilities and helpers to make the work as easy as possible: - we try to factorize as much as possible the different extractions to the - backends we target. - *) - -open Pure -open TranslateCore -module C = Contexts -module RegionVarId = T.RegionVarId -module F = Format - -(** The local logger *) -let log = L.pure_to_extract_log - -type region_group_info = { - id : RegionGroupId.id; - (** The id of the region group. - Note that a simple way of generating unique names for backward - functions is to use the region group ids. - *) - region_names : string option list; - (** The names of the region variables included in this group. - Note that names are not always available... - *) -} - -module StringSet = Collections.MakeSet (Collections.OrderedString) -module StringMap = Collections.MakeMap (Collections.OrderedString) - -type name = Names.name -type type_name = Names.type_name -type global_name = Names.global_name -type fun_name = Names.fun_name - -(* TODO: this should a module we give to a functor! *) - -(** A formatter's role is twofold: - 1. Come up with name suggestions. - For instance, provided some information about a function (its basename, - information about the region group, etc.) it should come up with an - appropriate name for the forward/backward function. - - It can of course apply many transformations, like changing to camel case/ - snake case, adding prefixes/suffixes, etc. - - 2. Format some specific terms, like constants. - *) -type formatter = { - bool_name : string; - char_name : string; - int_name : integer_type -> string; - str_name : string; - field_name : name -> FieldId.id -> string option -> string; - (** Inputs: - - type name - - field id - - field name - - Note that fields don't always have names, but we still need to - generate some names if we want to extract the structures to records... - We might want to extract such structures to tuples, later, but field - access then causes trouble because not all provers accept syntax like - [x.3] where [x] is a tuple. - *) - variant_name : name -> string -> string; - (** Inputs: - - type name - - variant name - *) - struct_constructor : name -> string; - (** Structure constructors are used when constructing structure values. - - For instance, in F*: - {[ - type pair = { x : nat; y : nat } - let p : pair = Mkpair 0 1 - ]} - - Inputs: - - type name - *) - type_name : type_name -> string; - (** Provided a basename, compute a type name. *) - global_name : global_name -> string; - (** Provided a basename, compute a global name. *) - fun_name : - A.fun_id -> - fun_name -> - int -> - region_group_info option -> - bool * int -> - string; - (** Inputs: - - function id: this is especially useful to identify whether the - function is an assumed function or a local function - - function basename - - number of region groups - - region group information in case of a backward function - ([None] if forward function) - - pair: - - do we generate the forward function (it may have been filtered)? - - the number of extracted backward functions (not necessarily equal - to the number of region groups, because we may have filtered - some of them) - TODO: use the fun id for the assumed functions. - *) - decreases_clause_name : A.FunDeclId.id -> fun_name -> string; - (** Generates the name of the definition used to prove/reason about - termination. The generated code uses this clause where needed, - but its body must be defined by the user. - - Inputs: - - function id: this is especially useful to identify whether the - function is an assumed function or a local function - - function basename - *) - var_basename : StringSet.t -> string option -> ty -> string; - (** Generates a variable basename. - - Inputs: - - the set of names used in the context so far - - the basename we got from the symbolic execution, if we have one - - the type of the variable (can be useful for heuristics, in order - not to always use "x" for instance, whenever naming anonymous - variables) - - Note that once the formatter generated a basename, we add an index - if necessary to prevent name clashes: the burden of name clashes checks - is thus on the caller's side. - *) - type_var_basename : StringSet.t -> string -> string; - (** Generates a type variable basename. *) - append_index : string -> int -> string; - (** Appends an index to a name - we use this to generate unique - names: when doing so, the role of the formatter is just to concatenate - indices to names, the responsability of finding a proper index is - delegated to helper functions. - *) - extract_constant_value : F.formatter -> bool -> constant_value -> unit; - (** Format a constant value. - - Inputs: - - formatter - - [inside]: if [true], the value should be wrapped in parentheses - if it is made of an application (ex.: [U32 3]) - - the constant value - *) - extract_unop : - (bool -> texpression -> unit) -> - F.formatter -> - bool -> - unop -> - texpression -> - unit; - (** Format a unary operation - - Inputs: - - a formatter for expressions (called on the argument of the unop) - - extraction context (see below) - - formatter - - expression formatter - - [inside] - - unop - - argument - *) - extract_binop : - (bool -> texpression -> unit) -> - F.formatter -> - bool -> - E.binop -> - integer_type -> - texpression -> - texpression -> - unit; - (** Format a binary operation - - Inputs: - - a formatter for expressions (called on the arguments of the binop) - - extraction context (see below) - - formatter - - expression formatter - - [inside] - - binop - - argument 0 - - argument 1 - *) -} - -(** We use identifiers to look for name clashes *) -type id = - | GlobalId of A.GlobalDeclId.id - | FunId of A.fun_id * RegionGroupId.id option - | DecreasesClauseId of A.fun_id - (** The definition which provides the decreases/termination clause. - We insert calls to this clause to prove/reason about termination: - the body of those clauses must be defined by the user, in the - proper files. - *) - | TypeId of type_id - | StructId of type_id - (** We use this when we manipulate the names of the structure - constructors. - - For instance, in F*: - {[ - type pair = { x: nat; y : nat } - let p : pair = Mkpair 0 1 - ]} - *) - | VariantId of type_id * VariantId.id - (** If often happens that variant names must be unique (it is the case in - F* ) which is why we register them here. - *) - | FieldId of type_id * FieldId.id - (** If often happens that in the case of structures, the field names - must be unique (it is the case in F* ) which is why we register - them here. - *) - | TypeVarId of TypeVarId.id - | VarId of VarId.id - | UnknownId - (** Used for stored various strings like keywords, definitions which - should always be in context, etc. and which can't be linked to one - of the above. - *) -[@@deriving show, ord] - -module IdOrderedType = struct - type t = id - - let compare = compare_id - let to_string = show_id - let pp_t = pp_id - let show_t = show_id -end - -module IdMap = Collections.MakeMap (IdOrderedType) - -(** The names map stores the mappings from names to identifiers and vice-versa. - - We use it for lookups (during the translation) and to check for name clashes. - - [id_to_string] is for debugging. - *) -type names_map = { - id_to_name : string IdMap.t; - name_to_id : id StringMap.t; - (** The name to id map is used to look for name clashes, and generate nice - debugging messages: if there is a name clash, it is useful to know - precisely which identifiers are mapped to the same name... - *) - names_set : StringSet.t; -} - -let names_map_add (id_to_string : id -> string) (id : id) (name : string) - (nm : names_map) : names_map = - (* Check if there is a clash *) - (match StringMap.find_opt name nm.name_to_id with - | None -> () (* Ok *) - | Some clash -> - (* There is a clash: print a nice debugging message for the user *) - let id1 = "\n- " ^ id_to_string clash in - let id2 = "\n- " ^ id_to_string id in - let err = - "Name clash detected: the following identifiers are bound to the same \ - name \"" ^ name ^ "\":" ^ id1 ^ id2 - in - log#serror err; - failwith err); - (* Sanity check *) - assert (not (StringSet.mem name nm.names_set)); - (* Insert *) - let id_to_name = IdMap.add id name nm.id_to_name in - let name_to_id = StringMap.add name id nm.name_to_id in - let names_set = StringSet.add name nm.names_set in - { id_to_name; name_to_id; names_set } - -let names_map_add_assumed_type (id_to_string : id -> string) (id : assumed_ty) - (name : string) (nm : names_map) : names_map = - names_map_add id_to_string (TypeId (Assumed id)) name nm - -let names_map_add_assumed_struct (id_to_string : id -> string) (id : assumed_ty) - (name : string) (nm : names_map) : names_map = - names_map_add id_to_string (StructId (Assumed id)) name nm - -let names_map_add_assumed_variant (id_to_string : id -> string) - (id : assumed_ty) (variant_id : VariantId.id) (name : string) - (nm : names_map) : names_map = - names_map_add id_to_string (VariantId (Assumed id, variant_id)) name nm - -let names_map_add_assumed_function (id_to_string : id -> string) - (fid : A.assumed_fun_id) (rg_id : RegionGroupId.id option) (name : string) - (nm : names_map) : names_map = - names_map_add id_to_string (FunId (A.Assumed fid, rg_id)) name nm - -(** Make a (variable) basename unique (by adding an index). - - We do this in an inefficient manner (by testing all indices starting from - 0) but it shouldn't be a bottleneck. - - Also note that at some point, we thought about trying to reuse names of - variables which are not used anymore, like here: - {[ - let x = ... in - ... - let x0 = ... in // We could use the name "x" if [x] is not used below - ... - ]} - - However it is a good idea to keep things as they are for F*: as F* is - designed for extrinsic proofs, a proof about a function follows this - function's structure. The consequence is that we often end up - copy-pasting function bodies. As in the proofs (in assertions and - when calling lemmas) we often need to talk about the "past" (i.e., - previous values), it is very useful to generate code where all variable - names are assigned at most once. - - [append]: function to append an index to a string - *) -let basename_to_unique (names_set : StringSet.t) - (append : string -> int -> string) (basename : string) : string = - let rec gen (i : int) : string = - let s = append basename i in - if StringSet.mem s names_set then gen (i + 1) else s - in - if StringSet.mem basename names_set then gen 0 else basename - -(** Extraction context. - - Note that the extraction context contains information coming from the - LLBC AST (not only the pure AST). This is useful for naming, for instance: - we use the region information to generate the names of the backward - functions, etc. - *) -type extraction_ctx = { - trans_ctx : trans_ctx; - names_map : names_map; - fmt : formatter; - indent_incr : int; - (** The indent increment we insert whenever we need to indent more *) -} - -(** Debugging function *) -let id_to_string (id : id) (ctx : extraction_ctx) : string = - let global_decls = ctx.trans_ctx.global_context.global_decls in - let fun_decls = ctx.trans_ctx.fun_context.fun_decls in - let type_decls = ctx.trans_ctx.type_context.type_decls in - (* TODO: factorize the pretty-printing with what is in PrintPure *) - let get_type_name (id : type_id) : string = - match id with - | AdtId id -> - let def = TypeDeclId.Map.find id type_decls in - Print.name_to_string def.name - | Assumed aty -> show_assumed_ty aty - | Tuple -> failwith "Unreachable" - in - match id with - | GlobalId gid -> - let name = (A.GlobalDeclId.Map.find gid global_decls).name in - "global name: " ^ Print.global_name_to_string name - | FunId (fid, rg_id) -> - let fun_name = - match fid with - | A.Regular fid -> - Print.fun_name_to_string (A.FunDeclId.Map.find fid fun_decls).name - | A.Assumed aid -> A.show_assumed_fun_id aid - in - let fun_kind = - match rg_id with - | None -> "forward" - | Some rg_id -> "backward " ^ RegionGroupId.to_string rg_id - in - "fun name (" ^ fun_kind ^ "): " ^ fun_name - | DecreasesClauseId fid -> - let fun_name = - match fid with - | A.Regular fid -> - Print.fun_name_to_string (A.FunDeclId.Map.find fid fun_decls).name - | A.Assumed aid -> A.show_assumed_fun_id aid - in - "decreases clause for function: " ^ fun_name - | TypeId id -> "type name: " ^ get_type_name id - | StructId id -> "struct constructor of: " ^ get_type_name id - | VariantId (id, variant_id) -> - let variant_name = - match id with - | Tuple -> failwith "Unreachable" - | Assumed State -> failwith "Unreachable" - | Assumed Result -> - if variant_id = result_return_id then "@result::Return" - else if variant_id = result_fail_id then "@result::Fail" - else failwith "Unreachable" - | Assumed Option -> - if variant_id = option_some_id then "@option::Some" - else if variant_id = option_none_id then "@option::None" - else failwith "Unreachable" - | Assumed Vec -> failwith "Unreachable" - | AdtId id -> ( - let def = TypeDeclId.Map.find id type_decls in - match def.kind with - | Struct _ | Opaque -> failwith "Unreachable" - | Enum variants -> - let variant = VariantId.nth variants variant_id in - Print.name_to_string def.name ^ "::" ^ variant.variant_name) - in - "variant name: " ^ variant_name - | FieldId (id, field_id) -> - let field_name = - match id with - | Tuple -> failwith "Unreachable" - | Assumed (State | Result | Option) -> failwith "Unreachable" - | Assumed Vec -> - (* We can't directly have access to the fields of a vector *) - failwith "Unreachable" - | AdtId id -> ( - let def = TypeDeclId.Map.find id type_decls in - match def.kind with - | Enum _ | Opaque -> failwith "Unreachable" - | Struct fields -> - let field = FieldId.nth fields field_id in - let field_name = - match field.field_name with - | None -> FieldId.to_string field_id - | Some name -> name - in - Print.name_to_string def.name ^ "." ^ field_name) - in - "field name: " ^ field_name - | UnknownId -> "keyword" - | TypeVarId _ | VarId _ -> - (* We should never get there: we add indices to make sure variable - * names are unique *) - failwith "Unreachable" - -let ctx_add (id : id) (name : string) (ctx : extraction_ctx) : extraction_ctx = - (* The id_to_string function to print nice debugging messages if there are - * collisions *) - let id_to_string (id : id) : string = id_to_string id ctx in - let names_map = names_map_add id_to_string id name ctx.names_map in - { ctx with names_map } - -let ctx_get (id : id) (ctx : extraction_ctx) : string = - match IdMap.find_opt id ctx.names_map.id_to_name with - | Some s -> s - | None -> - log#serror ("Could not find: " ^ id_to_string id ctx); - raise Not_found - -let ctx_get_global (id : A.GlobalDeclId.id) (ctx : extraction_ctx) : string = - ctx_get (GlobalId id) ctx - -let ctx_get_function (id : A.fun_id) (rg : RegionGroupId.id option) - (ctx : extraction_ctx) : string = - ctx_get (FunId (id, rg)) ctx - -let ctx_get_local_function (id : A.FunDeclId.id) (rg : RegionGroupId.id option) - (ctx : extraction_ctx) : string = - ctx_get_function (A.Regular id) rg ctx - -let ctx_get_type (id : type_id) (ctx : extraction_ctx) : string = - assert (id <> Tuple); - ctx_get (TypeId id) ctx - -let ctx_get_local_type (id : TypeDeclId.id) (ctx : extraction_ctx) : string = - ctx_get_type (AdtId id) ctx - -let ctx_get_assumed_type (id : assumed_ty) (ctx : extraction_ctx) : string = - ctx_get_type (Assumed id) ctx - -let ctx_get_var (id : VarId.id) (ctx : extraction_ctx) : string = - ctx_get (VarId id) ctx - -let ctx_get_type_var (id : TypeVarId.id) (ctx : extraction_ctx) : string = - ctx_get (TypeVarId id) ctx - -let ctx_get_field (type_id : type_id) (field_id : FieldId.id) - (ctx : extraction_ctx) : string = - ctx_get (FieldId (type_id, field_id)) ctx - -let ctx_get_struct (def_id : type_id) (ctx : extraction_ctx) : string = - ctx_get (StructId def_id) ctx - -let ctx_get_variant (def_id : type_id) (variant_id : VariantId.id) - (ctx : extraction_ctx) : string = - ctx_get (VariantId (def_id, variant_id)) ctx - -let ctx_get_decreases_clause (def_id : A.FunDeclId.id) (ctx : extraction_ctx) : - string = - ctx_get (DecreasesClauseId (A.Regular def_id)) ctx - -(** Generate a unique type variable name and add it to the context *) -let ctx_add_type_var (basename : string) (id : TypeVarId.id) - (ctx : extraction_ctx) : extraction_ctx * string = - let name = ctx.fmt.type_var_basename ctx.names_map.names_set basename in - let name = - basename_to_unique ctx.names_map.names_set ctx.fmt.append_index name - in - let ctx = ctx_add (TypeVarId id) name ctx in - (ctx, name) - -(** See {!ctx_add_type_var} *) -let ctx_add_type_vars (vars : (string * TypeVarId.id) list) - (ctx : extraction_ctx) : extraction_ctx * string list = - List.fold_left_map - (fun ctx (name, id) -> ctx_add_type_var name id ctx) - ctx vars - -(** Generate a unique variable name and add it to the context *) -let ctx_add_var (basename : string) (id : VarId.id) (ctx : extraction_ctx) : - extraction_ctx * string = - let name = - basename_to_unique ctx.names_map.names_set ctx.fmt.append_index basename - in - let ctx = ctx_add (VarId id) name ctx in - (ctx, name) - -(** See {!ctx_add_var} *) -let ctx_add_vars (vars : var list) (ctx : extraction_ctx) : - extraction_ctx * string list = - List.fold_left_map - (fun ctx (v : var) -> - let name = ctx.fmt.var_basename ctx.names_map.names_set v.basename v.ty in - ctx_add_var name v.id ctx) - ctx vars - -let ctx_add_type_params (vars : type_var list) (ctx : extraction_ctx) : - extraction_ctx * string list = - List.fold_left_map - (fun ctx (var : type_var) -> ctx_add_type_var var.name var.index ctx) - ctx vars - -let ctx_add_type_decl_struct (def : type_decl) (ctx : extraction_ctx) : - extraction_ctx * string = - let cons_name = ctx.fmt.struct_constructor def.name in - let ctx = ctx_add (StructId (AdtId def.def_id)) cons_name ctx in - (ctx, cons_name) - -let ctx_add_type_decl (def : type_decl) (ctx : extraction_ctx) : extraction_ctx - = - let def_name = ctx.fmt.type_name def.name in - let ctx = ctx_add (TypeId (AdtId def.def_id)) def_name ctx in - ctx - -let ctx_add_field (def : type_decl) (field_id : FieldId.id) (field : field) - (ctx : extraction_ctx) : extraction_ctx * string = - let name = ctx.fmt.field_name def.name field_id field.field_name in - let ctx = ctx_add (FieldId (AdtId def.def_id, field_id)) name ctx in - (ctx, name) - -let ctx_add_fields (def : type_decl) (fields : (FieldId.id * field) list) - (ctx : extraction_ctx) : extraction_ctx * string list = - List.fold_left_map - (fun ctx (vid, v) -> ctx_add_field def vid v ctx) - ctx fields - -let ctx_add_variant (def : type_decl) (variant_id : VariantId.id) - (variant : variant) (ctx : extraction_ctx) : extraction_ctx * string = - let name = ctx.fmt.variant_name def.name variant.variant_name in - let ctx = ctx_add (VariantId (AdtId def.def_id, variant_id)) name ctx in - (ctx, name) - -let ctx_add_variants (def : type_decl) - (variants : (VariantId.id * variant) list) (ctx : extraction_ctx) : - extraction_ctx * string list = - List.fold_left_map - (fun ctx (vid, v) -> ctx_add_variant def vid v ctx) - ctx variants - -let ctx_add_struct (def : type_decl) (ctx : extraction_ctx) : - extraction_ctx * string = - let name = ctx.fmt.struct_constructor def.name in - let ctx = ctx_add (StructId (AdtId def.def_id)) name ctx in - (ctx, name) - -let ctx_add_decrases_clause (def : fun_decl) (ctx : extraction_ctx) : - extraction_ctx = - let name = ctx.fmt.decreases_clause_name def.def_id def.basename in - ctx_add (DecreasesClauseId (A.Regular def.def_id)) name ctx - -let ctx_add_global_decl_and_body (def : A.global_decl) (ctx : extraction_ctx) : - extraction_ctx = - let name = ctx.fmt.global_name def.name in - let decl = GlobalId def.def_id in - let body = FunId (Regular def.body_id, None) in - let ctx = ctx_add decl (name ^ "_c") ctx in - let ctx = ctx_add body (name ^ "_body") ctx in - ctx - -let ctx_add_fun_decl (trans_group : bool * pure_fun_translation) - (def : fun_decl) (ctx : extraction_ctx) : extraction_ctx = - (* Sanity check: the function should not be a global body - those are handled - * separately *) - assert (not def.is_global_decl_body); - (* Lookup the LLBC def to compute the region group information *) - let def_id = def.def_id in - let llbc_def = - A.FunDeclId.Map.find def_id ctx.trans_ctx.fun_context.fun_decls - in - let sg = llbc_def.signature in - let num_rgs = List.length sg.regions_hierarchy in - let keep_fwd, (_, backs) = trans_group in - let num_backs = List.length backs in - let rg_info = - match def.back_id with - | None -> None - | Some rg_id -> - let rg = T.RegionGroupId.nth sg.regions_hierarchy rg_id in - let regions = - List.map - (fun rid -> T.RegionVarId.nth sg.region_params rid) - rg.regions - in - let region_names = - List.map (fun (r : T.region_var) -> r.name) regions - in - Some { id = rg_id; region_names } - in - let def_id = A.Regular def_id in - let name = - ctx.fmt.fun_name def_id def.basename num_rgs rg_info (keep_fwd, num_backs) - in - ctx_add (FunId (def_id, def.back_id)) name ctx - -type names_map_init = { - keywords : string list; - assumed_adts : (assumed_ty * string) list; - assumed_structs : (assumed_ty * string) list; - assumed_variants : (assumed_ty * VariantId.id * string) list; - assumed_functions : (A.assumed_fun_id * RegionGroupId.id option * string) list; -} - -(** Initialize a names map with a proper set of keywords/names coming from the - target language/prover. *) -let initialize_names_map (init : names_map_init) : names_map = - let name_to_id = - StringMap.of_list (List.map (fun x -> (x, UnknownId)) init.keywords) - in - let names_set = StringSet.of_list init.keywords in - (* We fist initialize [id_to_name] as empty, because the id of a keyword is [UnknownId]. - * Also note that we don't need this mapping for keywords: we insert keywords only - * to check collisions. *) - let id_to_name = IdMap.empty in - let nm = { id_to_name; name_to_id; names_set } in - (* For debugging - we are creating bindings for assumed types and functions, so - * it is ok if we simply use the "show" function (those aren't simply identified - * by numbers) *) - let id_to_string = show_id in - (* Then we add: - * - the assumed types - * - the assumed struct constructors - * - the assumed variants - * - the assumed functions - *) - let nm = - List.fold_left - (fun nm (type_id, name) -> - names_map_add_assumed_type id_to_string type_id name nm) - nm init.assumed_adts - in - let nm = - List.fold_left - (fun nm (type_id, name) -> - names_map_add_assumed_struct id_to_string type_id name nm) - nm init.assumed_structs - in - let nm = - List.fold_left - (fun nm (type_id, variant_id, name) -> - names_map_add_assumed_variant id_to_string type_id variant_id name nm) - nm init.assumed_variants - in - let nm = - List.fold_left - (fun nm (fun_id, rg_id, name) -> - names_map_add_assumed_function id_to_string fun_id rg_id name nm) - nm init.assumed_functions - in - (* Return *) - nm - -let compute_type_decl_name (fmt : formatter) (def : type_decl) : string = - fmt.type_name def.name - -(** A helper function: generates a function suffix from a region group - information. - TODO: move all those helpers. -*) -let default_fun_suffix (num_region_groups : int) (rg : region_group_info option) - ((keep_fwd, num_backs) : bool * int) : string = - (* There are several cases: - - [rg] is [Some]: this is a forward function: - - we add "_fwd" - - [rg] is [None]: this is a backward function: - - this function has one extracted backward function: - - if the forward function has been filtered, we add "_fwd_back": - the forward function is useless, so the unique backward function - takes its place, in a way - - otherwise we add "_back" - - this function has several backward functions: we add "_back" and an - additional suffix to identify the precise backward function - Note that we always add a suffix (in case there are no region groups, - we could not add the "_fwd" suffix) to prevent name clashes between - definitions (in particular between type and function definitions). - *) - match rg with - | None -> "_fwd" - | Some rg -> - assert (num_region_groups > 0 && num_backs > 0); - if num_backs = 1 then - (* Exactly one backward function *) - if not keep_fwd then "_fwd_back" else "_back" - else if - (* Several region groups/backward functions: - - if all the regions in the group have names, we use those names - - otherwise we use an index - *) - List.for_all Option.is_some rg.region_names - then - (* Concatenate the region names *) - "_back" ^ String.concat "" (List.map Option.get rg.region_names) - else (* Use the region index *) - "_back" ^ RegionGroupId.to_string rg.id diff --git a/src/PureTypeCheck.ml b/src/PureTypeCheck.ml deleted file mode 100644 index caad8a58..00000000 --- a/src/PureTypeCheck.ml +++ /dev/null @@ -1,178 +0,0 @@ -(** Module to perform type checking on the pure AST - we use this for sanity checks only *) - -open Pure -open PureUtils - -(** Utility function, used for type checking *) -let get_adt_field_types (type_decls : type_decl TypeDeclId.Map.t) - (type_id : type_id) (variant_id : VariantId.id option) (tys : ty list) : - ty list = - match type_id with - | Tuple -> - (* Tuple *) - assert (variant_id = None); - tys - | AdtId def_id -> - (* "Regular" ADT *) - let def = TypeDeclId.Map.find def_id type_decls in - type_decl_get_instantiated_fields_types def variant_id tys - | Assumed aty -> ( - (* Assumed type *) - match aty with - | State -> - (* [State] is opaque *) - raise (Failure "Unreachable: `State` values are opaque") - | Result -> - let ty = Collections.List.to_cons_nil tys in - let variant_id = Option.get variant_id in - if variant_id = result_return_id then [ ty ] - else if variant_id = result_fail_id then [] - else - raise (Failure "Unreachable: improper variant id for result type") - | Option -> - let ty = Collections.List.to_cons_nil tys in - let variant_id = Option.get variant_id in - if variant_id = option_some_id then [ ty ] - else if variant_id = option_none_id then [] - else - raise (Failure "Unreachable: improper variant id for result type") - | Vec -> raise (Failure "Unreachable: `Vector` values are opaque")) - -type tc_ctx = { - type_decls : type_decl TypeDeclId.Map.t; (** The type declarations *) - global_decls : A.global_decl A.GlobalDeclId.Map.t; - (** The global declarations *) - env : ty VarId.Map.t; (** Environment from variables to types *) -} - -let check_constant_value (v : constant_value) (ty : ty) : unit = - match (ty, v) with - | Integer int_ty, V.Scalar sv -> assert (int_ty = sv.V.int_ty) - | Bool, Bool _ | Char, Char _ | Str, String _ -> () - | _ -> raise (Failure "Inconsistent type") - -let rec check_typed_pattern (ctx : tc_ctx) (v : typed_pattern) : tc_ctx = - log#ldebug (lazy ("check_typed_pattern: " ^ show_typed_pattern v)); - match v.value with - | PatConcrete cv -> - check_constant_value cv v.ty; - ctx - | PatDummy -> ctx - | PatVar (var, _) -> - assert (var.ty = v.ty); - let env = VarId.Map.add var.id var.ty ctx.env in - { ctx with env } - | PatAdt av -> - (* Compute the field types *) - let type_id, tys = - match v.ty with - | Adt (type_id, tys) -> (type_id, tys) - | _ -> raise (Failure "Inconsistently typed value") - in - let field_tys = - get_adt_field_types ctx.type_decls type_id av.variant_id tys - in - let check_value (ctx : tc_ctx) (ty : ty) (v : typed_pattern) : tc_ctx = - if ty <> v.ty then ( - log#serror - ("check_typed_pattern: not the same types:" ^ "\n- ty: " - ^ show_ty ty ^ "\n- v.ty: " ^ show_ty v.ty); - raise (Failure "Inconsistent types")); - check_typed_pattern ctx v - in - (* Check the field types: check that the field patterns have the expected - * types, and check that the field patterns themselves are well-typed *) - List.fold_left - (fun ctx (ty, v) -> check_value ctx ty v) - ctx - (List.combine field_tys av.field_values) - -let rec check_texpression (ctx : tc_ctx) (e : texpression) : unit = - match e.e with - | Var var_id -> ( - (* Lookup the variable - note that the variable may not be there, - * if we type-check a subexpression (i.e.: if the variable is introduced - * "outside" of the expression) - TODO: this won't happen once - * we use a locally nameless representation *) - match VarId.Map.find_opt var_id ctx.env with - | None -> () - | Some ty -> assert (ty = e.ty)) - | Const cv -> check_constant_value cv e.ty - | App (app, arg) -> - let input_ty, output_ty = destruct_arrow app.ty in - assert (input_ty = arg.ty); - assert (output_ty = e.ty); - check_texpression ctx app; - check_texpression ctx arg - | Abs (pat, body) -> - let pat_ty, body_ty = destruct_arrow e.ty in - assert (pat.ty = pat_ty); - assert (body.ty = body_ty); - (* Check the pattern and register the introduced variables at the same time *) - let ctx = check_typed_pattern ctx pat in - check_texpression ctx body - | Qualif qualif -> ( - match qualif.id with - | Func _ -> () (* TODO *) - | Global _ -> () (* TODO *) - | Proj { adt_id = proj_adt_id; field_id } -> - (* Note we can only project fields of structures (not enumerations) *) - (* Deconstruct the projector type *) - let adt_ty, field_ty = destruct_arrow e.ty in - let adt_id, adt_type_args = - match adt_ty with - | Adt (type_id, tys) -> (type_id, tys) - | _ -> raise (Failure "Unreachable") - in - (* Check the ADT type *) - assert (adt_id = proj_adt_id); - assert (adt_type_args = qualif.type_args); - (* Retrieve and check the expected field type *) - let variant_id = None in - let expected_field_tys = - get_adt_field_types ctx.type_decls proj_adt_id variant_id - qualif.type_args - in - let expected_field_ty = FieldId.nth expected_field_tys field_id in - assert (expected_field_ty = field_ty) - | AdtCons id -> ( - let expected_field_tys = - get_adt_field_types ctx.type_decls id.adt_id id.variant_id - qualif.type_args - in - let field_tys, adt_ty = destruct_arrows e.ty in - assert (expected_field_tys = field_tys); - match adt_ty with - | Adt (type_id, tys) -> - assert (type_id = id.adt_id); - assert (tys = qualif.type_args) - | _ -> raise (Failure "Unreachable"))) - | Let (monadic, pat, re, e_next) -> - let expected_pat_ty = if monadic then destruct_result re.ty else re.ty in - assert (pat.ty = expected_pat_ty); - assert (e.ty = e_next.ty); - (* Check the right-expression *) - check_texpression ctx re; - (* Check the pattern and register the introduced variables at the same time *) - let ctx = check_typed_pattern ctx pat in - (* Check the next expression *) - check_texpression ctx e_next - | Switch (scrut, switch_body) -> ( - check_texpression ctx scrut; - match switch_body with - | If (e_then, e_else) -> - assert (scrut.ty = Bool); - assert (e_then.ty = e.ty); - assert (e_else.ty = e.ty); - check_texpression ctx e_then; - check_texpression ctx e_else - | Match branches -> - let check_branch (br : match_branch) : unit = - assert (br.pat.ty = scrut.ty); - let ctx = check_typed_pattern ctx br.pat in - check_texpression ctx br.branch - in - List.iter check_branch branches) - | Meta (_, e_next) -> - assert (e_next.ty = e.ty); - check_texpression ctx e_next diff --git a/src/PureUtils.ml b/src/PureUtils.ml deleted file mode 100644 index 39f3d76a..00000000 --- a/src/PureUtils.ml +++ /dev/null @@ -1,450 +0,0 @@ -open Pure - -(** Default logger *) -let log = Logging.pure_utils_log - -(** We use this type as a key for lookups *) -type regular_fun_id = A.fun_id * T.RegionGroupId.id option -[@@deriving show, ord] - -module RegularFunIdOrderedType = struct - type t = regular_fun_id - - let compare = compare_regular_fun_id - let to_string = show_regular_fun_id - let pp_t = pp_regular_fun_id - let show_t = show_regular_fun_id -end - -module RegularFunIdMap = Collections.MakeMap (RegularFunIdOrderedType) - -module FunIdOrderedType = struct - type t = fun_id - - let compare = compare_fun_id - let to_string = show_fun_id - let pp_t = pp_fun_id - let show_t = show_fun_id -end - -module FunIdMap = Collections.MakeMap (FunIdOrderedType) -module FunIdSet = Collections.MakeSet (FunIdOrderedType) - -let dest_arrow_ty (ty : ty) : ty * ty = - match ty with - | Arrow (arg_ty, ret_ty) -> (arg_ty, ret_ty) - | _ -> raise (Failure "Unreachable") - -let compute_constant_value_ty (cv : constant_value) : ty = - match cv with - | V.Scalar sv -> Integer sv.V.int_ty - | Bool _ -> Bool - | Char _ -> Char - | String _ -> Str - -let mk_typed_pattern_from_constant_value (cv : constant_value) : typed_pattern = - let ty = compute_constant_value_ty cv in - { value = PatConcrete cv; ty } - -let mk_let (monadic : bool) (lv : typed_pattern) (re : texpression) - (next_e : texpression) : texpression = - let e = Let (monadic, lv, re, next_e) in - let ty = next_e.ty in - { e; ty } - -(** Type substitution *) -let ty_substitute (tsubst : TypeVarId.id -> ty) (ty : ty) : ty = - let obj = - object - inherit [_] map_ty - method! visit_TypeVar _ var_id = tsubst var_id - end - in - obj#visit_ty () ty - -let make_type_subst (vars : type_var list) (tys : ty list) : TypeVarId.id -> ty - = - let ls = List.combine vars tys in - let mp = - List.fold_left - (fun mp (k, v) -> TypeVarId.Map.add (k : type_var).index v mp) - TypeVarId.Map.empty ls - in - fun id -> TypeVarId.Map.find id mp - -(** Retrieve the list of fields for the given variant of a {!Pure.type_decl}. - - Raises [Invalid_argument] if the arguments are incorrect. - *) -let type_decl_get_fields (def : type_decl) - (opt_variant_id : VariantId.id option) : field list = - match (def.kind, opt_variant_id) with - | Enum variants, Some variant_id -> (VariantId.nth variants variant_id).fields - | Struct fields, None -> fields - | _ -> - let opt_variant_id = - match opt_variant_id with None -> "None" | Some _ -> "Some" - in - raise - (Invalid_argument - ("The variant id should be [Some] if and only if the definition is \ - an enumeration:\n\ - - def: " ^ show_type_decl def ^ "\n- opt_variant_id: " - ^ opt_variant_id)) - -(** Instantiate the type variables for the chosen variant in an ADT definition, - and return the list of the types of its fields *) -let type_decl_get_instantiated_fields_types (def : type_decl) - (opt_variant_id : VariantId.id option) (types : ty list) : ty list = - let ty_subst = make_type_subst def.type_params types in - let fields = type_decl_get_fields def opt_variant_id in - List.map (fun f -> ty_substitute ty_subst f.field_ty) fields - -let fun_sig_substitute (tsubst : TypeVarId.id -> ty) (sg : fun_sig) : - inst_fun_sig = - let subst = ty_substitute tsubst in - let inputs = List.map subst sg.inputs in - let output = subst sg.output in - let doutputs = List.map subst sg.doutputs in - let info = sg.info in - { inputs; output; doutputs; info } - -(** Return true if a list of functions are *not* mutually recursive, false otherwise. - This function is meant to be applied on a set of (forward, backwards) functions - generated for one recursive function. - The way we do the test is very simple: - - we explore the functions one by one, in the order - - if all functions only call functions we already explored, they are not - mutually recursive - *) -let functions_not_mutually_recursive (funs : fun_decl list) : bool = - (* Compute the set of function identifiers in the group *) - let ids = - FunIdSet.of_list - (List.map - (fun (f : fun_decl) -> Regular (A.Regular f.def_id, f.back_id)) - funs) - in - let ids = ref ids in - (* Explore every body *) - let body_only_calls_itself (fdef : fun_decl) : bool = - (* Remove the current id from the id set *) - ids := FunIdSet.remove (Regular (A.Regular fdef.def_id, fdef.back_id)) !ids; - - (* Check if we call functions from the updated id set *) - let obj = - object - inherit [_] iter_expression as super - - method! visit_qualif env qualif = - match qualif.id with - | Func fun_id -> - if FunIdSet.mem fun_id !ids then raise Utils.Found - else super#visit_qualif env qualif - | _ -> super#visit_qualif env qualif - end - in - - try - match fdef.body with - | None -> true - | Some body -> - obj#visit_texpression () body.body; - true - with Utils.Found -> false - in - List.for_all body_only_calls_itself funs - -(** We use this to check whether we need to add parentheses around expressions. - We only look for outer monadic let-bindings. - This is used when printing the branches of [if ... then ... else ...]. - *) -let rec let_group_requires_parentheses (e : texpression) : bool = - match e.e with - | Var _ | Const _ | App _ | Abs _ | Qualif _ -> false - | Let (monadic, _, _, next_e) -> - if monadic then true else let_group_requires_parentheses next_e - | Switch (_, _) -> false - | Meta (_, next_e) -> let_group_requires_parentheses next_e - -let is_var (e : texpression) : bool = - match e.e with Var _ -> true | _ -> false - -let as_var (e : texpression) : VarId.id = - match e.e with Var v -> v | _ -> raise (Failure "Unreachable") - -let is_global (e : texpression) : bool = - match e.e with Qualif { id = Global _; _ } -> true | _ -> false - -let is_const (e : texpression) : bool = - match e.e with Const _ -> true | _ -> false - -(** Remove the external occurrences of {!Meta} *) -let rec unmeta (e : texpression) : texpression = - match e.e with Meta (_, e) -> unmeta e | _ -> e - -(** Remove *all* the meta information *) -let remove_meta (e : texpression) : texpression = - let obj = - object - inherit [_] map_expression as super - method! visit_Meta env _ e = super#visit_expression env e.e - end - in - obj#visit_texpression () e - -let mk_arrow (ty0 : ty) (ty1 : ty) : ty = Arrow (ty0, ty1) - -(** Construct a type as a list of arrows: ty1 -> ... tyn *) -let mk_arrows (inputs : ty list) (output : ty) = - let rec aux (tys : ty list) : ty = - match tys with [] -> output | ty :: tys' -> Arrow (ty, aux tys') - in - aux inputs - -(** Destruct an [App] expression into an expression and a list of arguments. - - We simply destruct the expression as long as it is of the form [App (f, x)]. - *) -let destruct_apps (e : texpression) : texpression * texpression list = - let rec aux (args : texpression list) (e : texpression) : - texpression * texpression list = - match e.e with App (f, x) -> aux (x :: args) f | _ -> (e, args) - in - aux [] e - -(** Make an [App (app, arg)] expression *) -let mk_app (app : texpression) (arg : texpression) : texpression = - match app.ty with - | Arrow (ty0, ty1) -> - (* Sanity check *) - assert (ty0 = arg.ty); - let e = App (app, arg) in - let ty = ty1 in - { e; ty } - | _ -> raise (Failure "Expected an arrow type") - -(** The reverse of {!destruct_apps} *) -let mk_apps (app : texpression) (args : texpression list) : texpression = - List.fold_left (fun app arg -> mk_app app arg) app args - -(** Destruct an expression into a qualif identifier and a list of arguments, - * if possible *) -let opt_destruct_qualif_app (e : texpression) : - (qualif * texpression list) option = - let app, args = destruct_apps e in - match app.e with Qualif qualif -> Some (qualif, args) | _ -> None - -(** Destruct an expression into a qualif identifier and a list of arguments *) -let destruct_qualif_app (e : texpression) : qualif * texpression list = - Option.get (opt_destruct_qualif_app e) - -(** Destruct an expression into a function call, if possible *) -let opt_destruct_function_call (e : texpression) : - (fun_id * ty list * texpression list) option = - match opt_destruct_qualif_app e with - | None -> None - | Some (qualif, args) -> ( - match qualif.id with - | Func fun_id -> Some (fun_id, qualif.type_args, args) - | _ -> None) - -let opt_destruct_result (ty : ty) : ty option = - match ty with - | Adt (Assumed Result, tys) -> Some (Collections.List.to_cons_nil tys) - | _ -> None - -let destruct_result (ty : ty) : ty = Option.get (opt_destruct_result ty) - -let opt_destruct_tuple (ty : ty) : ty list option = - match ty with Adt (Tuple, tys) -> Some tys | _ -> None - -let mk_abs (x : typed_pattern) (e : texpression) : texpression = - let ty = Arrow (x.ty, e.ty) in - let e = Abs (x, e) in - { e; ty } - -let rec destruct_abs_list (e : texpression) : typed_pattern list * texpression = - match e.e with - | Abs (x, e') -> - let xl, e'' = destruct_abs_list e' in - (x :: xl, e'') - | _ -> ([], e) - -let destruct_arrow (ty : ty) : ty * ty = - match ty with - | Arrow (ty0, ty1) -> (ty0, ty1) - | _ -> raise (Failure "Not an arrow type") - -let rec destruct_arrows (ty : ty) : ty list * ty = - match ty with - | Arrow (ty0, ty1) -> - let tys, out_ty = destruct_arrows ty1 in - (ty0 :: tys, out_ty) - | _ -> ([], ty) - -let get_switch_body_ty (sb : switch_body) : ty = - match sb with - | If (e_then, _) -> e_then.ty - | Match branches -> - (* There should be at least one branch *) - (List.hd branches).branch.ty - -let map_switch_body_branches (f : texpression -> texpression) (sb : switch_body) - : switch_body = - match sb with - | If (e_then, e_else) -> If (f e_then, f e_else) - | Match branches -> - Match - (List.map - (fun (b : match_branch) -> { b with branch = f b.branch }) - branches) - -let iter_switch_body_branches (f : texpression -> unit) (sb : switch_body) : - unit = - match sb with - | If (e_then, e_else) -> - f e_then; - f e_else - | Match branches -> List.iter (fun (b : match_branch) -> f b.branch) branches - -let mk_switch (scrut : texpression) (sb : switch_body) : texpression = - (* Sanity check: the scrutinee has the proper type *) - (match sb with - | If (_, _) -> assert (scrut.ty = Bool) - | Match branches -> - List.iter - (fun (b : match_branch) -> assert (b.pat.ty = scrut.ty)) - branches); - (* Sanity check: all the branches have the same type *) - let ty = get_switch_body_ty sb in - iter_switch_body_branches (fun e -> assert (e.ty = ty)) sb; - (* Put together *) - let e = Switch (scrut, sb) in - { e; ty } - -(** Make a "simplified" tuple type from a list of types: - - if there is exactly one type, just return it - - if there is > one type: wrap them in a tuple - *) -let mk_simpl_tuple_ty (tys : ty list) : ty = - match tys with [ ty ] -> ty | _ -> Adt (Tuple, tys) - -let mk_unit_ty : ty = Adt (Tuple, []) - -let mk_unit_rvalue : texpression = - let id = AdtCons { adt_id = Tuple; variant_id = None } in - let qualif = { id; type_args = [] } in - let e = Qualif qualif in - let ty = mk_unit_ty in - { e; ty } - -let mk_texpression_from_var (v : var) : texpression = - let e = Var v.id in - let ty = v.ty in - { e; ty } - -let mk_typed_pattern_from_var (v : var) (mp : mplace option) : typed_pattern = - let value = PatVar (v, mp) in - let ty = v.ty in - { value; ty } - -let mk_meta (m : meta) (e : texpression) : texpression = - let ty = e.ty in - let e = Meta (m, e) in - { e; ty } - -let mk_mplace_texpression (mp : mplace) (e : texpression) : texpression = - mk_meta (MPlace mp) e - -let mk_opt_mplace_texpression (mp : mplace option) (e : texpression) : - texpression = - match mp with None -> e | Some mp -> mk_mplace_texpression mp e - -(** Make a "simplified" tuple value from a list of values: - - if there is exactly one value, just return it - - if there is > one value: wrap them in a tuple - *) -let mk_simpl_tuple_pattern (vl : typed_pattern list) : typed_pattern = - match vl with - | [ v ] -> v - | _ -> - let tys = List.map (fun (v : typed_pattern) -> v.ty) vl in - let ty = Adt (Tuple, tys) in - let value = PatAdt { variant_id = None; field_values = vl } in - { value; ty } - -(** Similar to {!mk_simpl_tuple_pattern} *) -let mk_simpl_tuple_texpression (vl : texpression list) : texpression = - match vl with - | [ v ] -> v - | _ -> - (* Compute the types of the fields, and the type of the tuple constructor *) - let tys = List.map (fun (v : texpression) -> v.ty) vl in - let ty = Adt (Tuple, tys) in - let ty = mk_arrows tys ty in - (* Construct the tuple constructor qualifier *) - let id = AdtCons { adt_id = Tuple; variant_id = None } in - let qualif = { id; type_args = tys } in - (* Put everything together *) - let cons = { e = Qualif qualif; ty } in - mk_apps cons vl - -let mk_adt_pattern (adt_ty : ty) (variant_id : VariantId.id) - (vl : typed_pattern list) : typed_pattern = - let value = PatAdt { variant_id = Some variant_id; field_values = vl } in - { value; ty = adt_ty } - -let ty_as_integer (t : ty) : T.integer_type = - match t with Integer int_ty -> int_ty | _ -> raise (Failure "Unreachable") - -(* TODO: move *) -let type_decl_is_enum (def : T.type_decl) : bool = - match def.kind with T.Struct _ -> false | Enum _ -> true | Opaque -> false - -let mk_state_ty : ty = Adt (Assumed State, []) -let mk_result_ty (ty : ty) : ty = Adt (Assumed Result, [ ty ]) - -let unwrap_result_ty (ty : ty) : ty = - match ty with - | Adt (Assumed Result, [ ty ]) -> ty - | _ -> failwith "not a result type" - -let mk_result_fail_texpression (ty : ty) : texpression = - let type_args = [ ty ] in - let ty = Adt (Assumed Result, type_args) in - let id = - AdtCons { adt_id = Assumed Result; variant_id = Some result_fail_id } - in - let qualif = { id; type_args } in - let cons_e = Qualif qualif in - let cons_ty = ty in - let cons = { e = cons_e; ty = cons_ty } in - cons - -let mk_result_return_texpression (v : texpression) : texpression = - let type_args = [ v.ty ] in - let ty = Adt (Assumed Result, type_args) in - let id = - AdtCons { adt_id = Assumed Result; variant_id = Some result_return_id } - in - let qualif = { id; type_args } in - let cons_e = Qualif qualif in - let cons_ty = mk_arrow v.ty ty in - let cons = { e = cons_e; ty = cons_ty } in - mk_app cons v - -let mk_result_fail_pattern (ty : ty) : typed_pattern = - let ty = Adt (Assumed Result, [ ty ]) in - let value = PatAdt { variant_id = Some result_fail_id; field_values = [] } in - { value; ty } - -let mk_result_return_pattern (v : typed_pattern) : typed_pattern = - let ty = Adt (Assumed Result, [ v.ty ]) in - let value = - PatAdt { variant_id = Some result_return_id; field_values = [ v ] } - in - { value; ty } - -let opt_unmeta_mplace (e : texpression) : mplace option * texpression = - match e.e with Meta (MPlace mp, e) -> (Some mp, e) | _ -> (None, e) diff --git a/src/Scalars.ml b/src/Scalars.ml deleted file mode 100644 index 03ca506c..00000000 --- a/src/Scalars.ml +++ /dev/null @@ -1,59 +0,0 @@ -open Types -open Values - -(** The minimum/maximum values an integer type can have depending on its type *) - -let i8_min = Z.of_string "-128" -let i8_max = Z.of_string "127" -let i16_min = Z.of_string "-32768" -let i16_max = Z.of_string "32767" -let i32_min = Z.of_string "-2147483648" -let i32_max = Z.of_string "2147483647" -let i64_min = Z.of_string "-9223372036854775808" -let i64_max = Z.of_string "9223372036854775807" -let i128_min = Z.of_string "-170141183460469231731687303715884105728" -let i128_max = Z.of_string "170141183460469231731687303715884105727" -let u8_min = Z.of_string "0" -let u8_max = Z.of_string "255" -let u16_min = Z.of_string "0" -let u16_max = Z.of_string "65535" -let u32_min = Z.of_string "0" -let u32_max = Z.of_string "4294967295" -let u64_min = Z.of_string "0" -let u64_max = Z.of_string "18446744073709551615" -let u128_min = Z.of_string "0" -let u128_max = Z.of_string "340282366920938463463374607431768211455" - -(** Being a bit conservative about isize/usize: depending on the system, - the values are encoded as 32-bit values or 64-bit values - we may - want to take that into account in the future *) - -let isize_min = i32_min -let isize_max = i32_max -let usize_min = u32_min -let usize_max = u32_max - -(** Check that an integer value is in range *) -let check_int_in_range (int_ty : integer_type) (i : big_int) : bool = - match int_ty with - | Isize -> Z.leq isize_min i && Z.leq i isize_max - | I8 -> Z.leq i8_min i && Z.leq i i8_max - | I16 -> Z.leq i16_min i && Z.leq i i16_max - | I32 -> Z.leq i32_min i && Z.leq i i32_max - | I64 -> Z.leq i64_min i && Z.leq i i64_max - | I128 -> Z.leq i128_min i && Z.leq i i128_max - | Usize -> Z.leq usize_min i && Z.leq i usize_max - | U8 -> Z.leq u8_min i && Z.leq i u8_max - | U16 -> Z.leq u16_min i && Z.leq i u16_max - | U32 -> Z.leq u32_min i && Z.leq i u32_max - | U64 -> Z.leq u64_min i && Z.leq i u64_max - | U128 -> Z.leq u128_min i && Z.leq i u128_max - -(** Check that a scalar value is correct (the integer value it contains is in range) *) -let check_scalar_value_in_range (v : scalar_value) : bool = - check_int_in_range v.int_ty v.value - -(** Make a scalar value, while checking the value is in range *) -let mk_scalar (int_ty : integer_type) (i : big_int) : - (scalar_value, unit) result = - if check_int_in_range int_ty i then Ok { value = i; int_ty } else Error () diff --git a/src/StringUtils.ml b/src/StringUtils.ml deleted file mode 100644 index 0fd46136..00000000 --- a/src/StringUtils.ml +++ /dev/null @@ -1,106 +0,0 @@ -(** Utilities to work on strings, character per character. - - They operate on ASCII strings, and are used by the project to convert - Rust names: Rust names are not fancy, so it shouldn't be a problem. - - Rk.: the poor support of OCaml for char manipulation is really annoying... - *) - -let code_0 = 48 -let code_9 = 57 -let code_A = 65 -let code_Z = 90 -let code_a = 97 -let code_z = 122 - -let is_lowercase_ascii (c : char) : bool = - let c = Char.code c in - code_a <= c && c <= code_z - -let is_uppercase_ascii (c : char) : bool = - let c = Char.code c in - code_A <= c && c <= code_Z - -let is_letter_ascii (c : char) : bool = - is_lowercase_ascii c || is_uppercase_ascii c - -let is_digit_ascii (c : char) : bool = - let c = Char.code c in - code_0 <= c && c <= code_9 - -let lowercase_ascii = Char.lowercase_ascii -let uppercase_ascii = Char.uppercase_ascii - -(** Using buffers as per: - {{: https://stackoverflow.com/questions/29957418/how-to-convert-char-list-to-string-in-ocaml} stackoverflow} - *) -let string_of_chars (chars : char list) : string = - let buf = Buffer.create (List.length chars) in - List.iter (Buffer.add_char buf) chars; - Buffer.contents buf - -let string_to_chars (s : string) : char list = - let length = String.length s in - let rec apply i = - if i = length then [] else String.get s i :: apply (i + 1) - in - apply 0 - -(** This operates on ASCII *) -let to_camel_case (s : string) : string = - (* Note that we rebuild the string in reverse order *) - let apply ((prev_is_under, acc) : bool * char list) (c : char) : - bool * char list = - if c = '_' then (true, acc) - else - let c = if prev_is_under then uppercase_ascii c else c in - (false, c :: acc) - in - let _, chars = List.fold_left apply (true, []) (string_to_chars s) in - string_of_chars (List.rev chars) - -(** This operates on ASCII *) -let to_snake_case (s : string) : string = - (* Note that we rebuild the string in reverse order *) - let apply ((prev_is_low, prev_is_digit, acc) : bool * bool * char list) - (c : char) : bool * bool * char list = - let acc = - if c = '_' then acc - else if prev_is_digit then if is_letter_ascii c then '_' :: acc else acc - else if prev_is_low then - if (is_lowercase_ascii c || is_digit_ascii c) && c <> '_' then acc - else '_' :: acc - else acc - in - let prev_is_low = is_lowercase_ascii c in - let prev_is_digit = is_digit_ascii c in - let c = lowercase_ascii c in - (prev_is_low, prev_is_digit, c :: acc) - in - let _, _, chars = - List.fold_left apply (false, false, []) (string_to_chars s) - in - string_of_chars (List.rev chars) - -(** Applies a map operation. - - This is very inefficient, but shouldn't be used much. - *) -let map (f : char -> string) (s : string) : string = - let sl = List.map f (string_to_chars s) in - let sl = List.map string_to_chars sl in - string_of_chars (List.concat sl) - -let capitalize_first_letter (s : string) : string = - let s = string_to_chars s in - let s = match s with [] -> s | c :: s' -> uppercase_ascii c :: s' in - string_of_chars s - -(** Unit tests *) -let _ = - assert (to_camel_case "hello_world" = "HelloWorld"); - assert (to_snake_case "HelloWorld36Hello" = "hello_world36_hello"); - assert (to_snake_case "HELLO" = "hello"); - assert (to_snake_case "T1" = "t1"); - assert (to_camel_case "list" = "List"); - assert (to_snake_case "is_cons" = "is_cons") diff --git a/src/Substitute.ml b/src/Substitute.ml deleted file mode 100644 index 5e5858de..00000000 --- a/src/Substitute.ml +++ /dev/null @@ -1,357 +0,0 @@ -(** This file implements various substitution utilities to instantiate types, - function bodies, etc. - *) - -module T = Types -module TU = TypesUtils -module V = Values -module E = Expressions -module A = LlbcAst -module C = Contexts - -(** Substitute types variables and regions in a type. - - TODO: we can reimplement that with visitors. - *) -let rec ty_substitute (rsubst : 'r1 -> 'r2) - (tsubst : T.TypeVarId.id -> 'r2 T.ty) (ty : 'r1 T.ty) : 'r2 T.ty = - let open T in - let subst = ty_substitute rsubst tsubst in - (* helper *) - match ty with - | Adt (def_id, regions, tys) -> - Adt (def_id, List.map rsubst regions, List.map subst tys) - | Array aty -> Array (subst aty) - | Slice sty -> Slice (subst sty) - | Ref (r, ref_ty, ref_kind) -> Ref (rsubst r, subst ref_ty, ref_kind) - (* Below variants: we technically return the same value, but because - one has type ['r1 ty] and the other has type ['r2 ty], we need to - deconstruct then reconstruct *) - | Bool -> Bool - | Char -> Char - | Never -> Never - | Integer int_ty -> Integer int_ty - | Str -> Str - | TypeVar vid -> tsubst vid - -(** Convert an {!T.rty} to an {!T.ety} by erasing the region variables *) -let erase_regions (ty : T.rty) : T.ety = - ty_substitute (fun _ -> T.Erased) (fun vid -> T.TypeVar vid) ty - -(** Generate fresh regions for region variables. - - Return the list of new regions and appropriate substitutions from the - original region variables to the fresh regions. - - TODO: simplify? we only need the subst [T.RegionVarId.id -> T.RegionId.id] - *) -let fresh_regions_with_substs (region_vars : T.region_var list) : - T.RegionId.id list - * (T.RegionVarId.id -> T.RegionId.id) - * (T.RegionVarId.id T.region -> T.RegionId.id T.region) = - (* Generate fresh regions *) - let fresh_region_ids = List.map (fun _ -> C.fresh_region_id ()) region_vars in - (* Generate the map from region var ids to regions *) - let ls = List.combine region_vars fresh_region_ids in - let rid_map = - List.fold_left - (fun mp (k, v) -> T.RegionVarId.Map.add k.T.index v mp) - T.RegionVarId.Map.empty ls - in - (* Generate the substitution from region var id to region *) - let rid_subst id = T.RegionVarId.Map.find id rid_map in - (* Generate the substitution from region to region *) - let rsubst r = - match r with T.Static -> T.Static | T.Var id -> T.Var (rid_subst id) - in - (* Return *) - (fresh_region_ids, rid_subst, rsubst) - -(** Erase the regions in a type and substitute the type variables *) -let erase_regions_substitute_types (tsubst : T.TypeVarId.id -> T.ety) - (ty : 'r T.region T.ty) : T.ety = - let rsubst (_ : 'r T.region) : T.erased_region = T.Erased in - ty_substitute rsubst tsubst ty - -(** Create a region substitution from a list of region variable ids and a list of - regions (with which to substitute the region variable ids *) -let make_region_subst (var_ids : T.RegionVarId.id list) - (regions : 'r T.region list) : T.RegionVarId.id T.region -> 'r T.region = - let ls = List.combine var_ids regions in - let mp = - List.fold_left - (fun mp (k, v) -> T.RegionVarId.Map.add k v mp) - T.RegionVarId.Map.empty ls - in - fun r -> - match r with - | T.Static -> T.Static - | T.Var id -> T.RegionVarId.Map.find id mp - -(** Create a type substitution from a list of type variable ids and a list of - types (with which to substitute the type variable ids) *) -let make_type_subst (var_ids : T.TypeVarId.id list) (tys : 'r T.ty list) : - T.TypeVarId.id -> 'r T.ty = - let ls = List.combine var_ids tys in - let mp = - List.fold_left - (fun mp (k, v) -> T.TypeVarId.Map.add k v mp) - T.TypeVarId.Map.empty ls - in - fun id -> T.TypeVarId.Map.find id mp - -(** Instantiate the type variables in an ADT definition, and return, for - every variant, the list of the types of its fields *) -let type_decl_get_instantiated_variants_fields_rtypes (def : T.type_decl) - (regions : T.RegionId.id T.region list) (types : T.rty list) : - (T.VariantId.id option * T.rty list) list = - let r_subst = - make_region_subst - (List.map (fun x -> x.T.index) def.T.region_params) - regions - in - let ty_subst = - make_type_subst (List.map (fun x -> x.T.index) def.T.type_params) types - in - let (variants_fields : (T.VariantId.id option * T.field list) list) = - match def.T.kind with - | T.Enum variants -> - List.mapi - (fun i v -> (Some (T.VariantId.of_int i), v.T.fields)) - variants - | T.Struct fields -> [ (None, fields) ] - | T.Opaque -> - raise - (Failure - ("Can't retrieve the variants of an opaque type: " - ^ Names.name_to_string def.name)) - in - List.map - (fun (id, fields) -> - ( id, - List.map (fun f -> ty_substitute r_subst ty_subst f.T.field_ty) fields - )) - variants_fields - -(** Instantiate the type variables in an ADT definition, and return the list - of types of the fields for the chosen variant *) -let type_decl_get_instantiated_field_rtypes (def : T.type_decl) - (opt_variant_id : T.VariantId.id option) - (regions : T.RegionId.id T.region list) (types : T.rty list) : T.rty list = - let r_subst = - make_region_subst - (List.map (fun x -> x.T.index) def.T.region_params) - regions - in - let ty_subst = - make_type_subst (List.map (fun x -> x.T.index) def.T.type_params) types - in - let fields = TU.type_decl_get_fields def opt_variant_id in - List.map (fun f -> ty_substitute r_subst ty_subst f.T.field_ty) fields - -(** Return the types of the properly instantiated ADT's variant, provided a - context *) -let ctx_adt_get_instantiated_field_rtypes (ctx : C.eval_ctx) - (def_id : T.TypeDeclId.id) (opt_variant_id : T.VariantId.id option) - (regions : T.RegionId.id T.region list) (types : T.rty list) : T.rty list = - let def = C.ctx_lookup_type_decl ctx def_id in - type_decl_get_instantiated_field_rtypes def opt_variant_id regions types - -(** Return the types of the properly instantiated ADT value (note that - here, ADT is understood in its broad meaning: ADT, assumed value or tuple) *) -let ctx_adt_value_get_instantiated_field_rtypes (ctx : C.eval_ctx) - (adt : V.adt_value) (id : T.type_id) - (region_params : T.RegionId.id T.region list) (type_params : T.rty list) : - T.rty list = - match id with - | T.AdtId id -> - (* Retrieve the types of the fields *) - ctx_adt_get_instantiated_field_rtypes ctx id adt.V.variant_id - region_params type_params - | T.Tuple -> - assert (List.length region_params = 0); - type_params - | T.Assumed aty -> ( - match aty with - | T.Box | T.Vec -> - assert (List.length region_params = 0); - assert (List.length type_params = 1); - type_params - | T.Option -> - assert (List.length region_params = 0); - assert (List.length type_params = 1); - if adt.V.variant_id = Some T.option_some_id then type_params - else if adt.V.variant_id = Some T.option_none_id then [] - else failwith "Unrechable") - -(** Instantiate the type variables in an ADT definition, and return the list - of types of the fields for the chosen variant *) -let type_decl_get_instantiated_field_etypes (def : T.type_decl) - (opt_variant_id : T.VariantId.id option) (types : T.ety list) : T.ety list = - let ty_subst = - make_type_subst (List.map (fun x -> x.T.index) def.T.type_params) types - in - let fields = TU.type_decl_get_fields def opt_variant_id in - List.map - (fun f -> erase_regions_substitute_types ty_subst f.T.field_ty) - fields - -(** Return the types of the properly instantiated ADT's variant, provided a - context *) -let ctx_adt_get_instantiated_field_etypes (ctx : C.eval_ctx) - (def_id : T.TypeDeclId.id) (opt_variant_id : T.VariantId.id option) - (types : T.ety list) : T.ety list = - let def = C.ctx_lookup_type_decl ctx def_id in - type_decl_get_instantiated_field_etypes def opt_variant_id types - -(** Apply a type substitution to a place *) -let place_substitute (_tsubst : T.TypeVarId.id -> T.ety) (p : E.place) : E.place - = - (* There is nothing to do *) - p - -(** Apply a type substitution to an operand *) -let operand_substitute (tsubst : T.TypeVarId.id -> T.ety) (op : E.operand) : - E.operand = - let p_subst = place_substitute tsubst in - match op with - | E.Copy p -> E.Copy (p_subst p) - | E.Move p -> E.Move (p_subst p) - | E.Constant (ety, cv) -> - let rsubst x = x in - E.Constant (ty_substitute rsubst tsubst ety, cv) - -(** Apply a type substitution to an rvalue *) -let rvalue_substitute (tsubst : T.TypeVarId.id -> T.ety) (rv : E.rvalue) : - E.rvalue = - let op_subst = operand_substitute tsubst in - let p_subst = place_substitute tsubst in - match rv with - | E.Use op -> E.Use (op_subst op) - | E.Ref (p, bkind) -> E.Ref (p_subst p, bkind) - | E.UnaryOp (unop, op) -> E.UnaryOp (unop, op_subst op) - | E.BinaryOp (binop, op1, op2) -> - E.BinaryOp (binop, op_subst op1, op_subst op2) - | E.Discriminant p -> E.Discriminant (p_subst p) - | E.Aggregate (kind, ops) -> - let ops = List.map op_subst ops in - let kind = - match kind with - | E.AggregatedTuple -> E.AggregatedTuple - | E.AggregatedOption (variant_id, ty) -> - let rsubst r = r in - E.AggregatedOption (variant_id, ty_substitute rsubst tsubst ty) - | E.AggregatedAdt (def_id, variant_id, regions, tys) -> - let rsubst r = r in - E.AggregatedAdt - ( def_id, - variant_id, - regions, - List.map (ty_substitute rsubst tsubst) tys ) - in - E.Aggregate (kind, ops) - -(** Apply a type substitution to an assertion *) -let assertion_substitute (tsubst : T.TypeVarId.id -> T.ety) (a : A.assertion) : - A.assertion = - { A.cond = operand_substitute tsubst a.A.cond; A.expected = a.A.expected } - -(** Apply a type substitution to a call *) -let call_substitute (tsubst : T.TypeVarId.id -> T.ety) (call : A.call) : A.call - = - let rsubst x = x in - let type_args = List.map (ty_substitute rsubst tsubst) call.A.type_args in - let args = List.map (operand_substitute tsubst) call.A.args in - let dest = place_substitute tsubst call.A.dest in - (* Putting all the paramters on purpose: we want to get a compiler error if - something moves - we may add a field on which we need to apply a substitution *) - { - func = call.A.func; - region_args = call.A.region_args; - A.type_args; - args; - dest; - } - -(** Apply a type substitution to a statement *) -let rec statement_substitute (tsubst : T.TypeVarId.id -> T.ety) - (st : A.statement) : A.statement = - { st with A.content = raw_statement_substitute tsubst st.content } - -and raw_statement_substitute (tsubst : T.TypeVarId.id -> T.ety) - (st : A.raw_statement) : A.raw_statement = - match st with - | A.Assign (p, rvalue) -> - let p = place_substitute tsubst p in - let rvalue = rvalue_substitute tsubst rvalue in - A.Assign (p, rvalue) - | A.AssignGlobal g -> - (* Globals don't have type parameters *) - A.AssignGlobal g - | A.FakeRead p -> - let p = place_substitute tsubst p in - A.FakeRead p - | A.SetDiscriminant (p, vid) -> - let p = place_substitute tsubst p in - A.SetDiscriminant (p, vid) - | A.Drop p -> - let p = place_substitute tsubst p in - A.Drop p - | A.Assert assertion -> - let assertion = assertion_substitute tsubst assertion in - A.Assert assertion - | A.Call call -> - let call = call_substitute tsubst call in - A.Call call - | A.Panic | A.Return | A.Break _ | A.Continue _ | A.Nop -> st - | A.Sequence (st1, st2) -> - A.Sequence - (statement_substitute tsubst st1, statement_substitute tsubst st2) - | A.Switch (op, tgts) -> - A.Switch - (operand_substitute tsubst op, switch_targets_substitute tsubst tgts) - | A.Loop le -> A.Loop (statement_substitute tsubst le) - -(** Apply a type substitution to switch targets *) -and switch_targets_substitute (tsubst : T.TypeVarId.id -> T.ety) - (tgts : A.switch_targets) : A.switch_targets = - match tgts with - | A.If (st1, st2) -> - A.If (statement_substitute tsubst st1, statement_substitute tsubst st2) - | A.SwitchInt (int_ty, tgts, otherwise) -> - let tgts = - List.map (fun (sv, st) -> (sv, statement_substitute tsubst st)) tgts - in - let otherwise = statement_substitute tsubst otherwise in - A.SwitchInt (int_ty, tgts, otherwise) - -(** Apply a type substitution to a function body. Return the local variables - and the body. *) -let fun_body_substitute_in_body (tsubst : T.TypeVarId.id -> T.ety) - (body : A.fun_body) : A.var list * A.statement = - let rsubst r = r in - let locals = - List.map - (fun v -> { v with A.var_ty = ty_substitute rsubst tsubst v.A.var_ty }) - body.A.locals - in - let body = statement_substitute tsubst body.body in - (locals, body) - -(** Substitute a function signature *) -let substitute_signature (asubst : T.RegionGroupId.id -> V.AbstractionId.id) - (rsubst : T.RegionVarId.id -> T.RegionId.id) - (tsubst : T.TypeVarId.id -> T.rty) (sg : A.fun_sig) : A.inst_fun_sig = - let rsubst' (r : T.RegionVarId.id T.region) : T.RegionId.id T.region = - match r with T.Static -> T.Static | T.Var rid -> T.Var (rsubst rid) - in - let inputs = List.map (ty_substitute rsubst' tsubst) sg.A.inputs in - let output = ty_substitute rsubst' tsubst sg.A.output in - let subst_region_group (rg : T.region_var_group) : A.abs_region_group = - let id = asubst rg.id in - let regions = List.map rsubst rg.regions in - let parents = List.map asubst rg.parents in - { id; regions; parents } - in - let regions_hierarchy = List.map subst_region_group sg.A.regions_hierarchy in - { A.regions_hierarchy; inputs; output } diff --git a/src/SymbolicAst.ml b/src/SymbolicAst.ml deleted file mode 100644 index 604a7948..00000000 --- a/src/SymbolicAst.ml +++ /dev/null @@ -1,98 +0,0 @@ -(** The "symbolic" AST is the AST directly generated by the symbolic execution. - It is very rough and meant to be extremely straightforward to build during - the symbolic execution: we later apply transformations to generate the - pure AST that we export. *) - -module T = Types -module V = Values -module E = Expressions -module A = LlbcAst - -(** "Meta"-place: a place stored as meta-data. - - Whenever we need to introduce new symbolic variables, for instance because - of symbolic expansions, we try to store a "place", which gives information - about the origin of the values (this place information comes from assignment - information, etc.). - We later use this place information to generate meaningful name, to prettify - the generated code. - *) -type mplace = { - bv : Contexts.binder; - (** It is important that we store the binder, and not just the variable id, - because the most important information in a place is the name of the - variable! - *) - projection : E.projection; - (** We store the projection because we can, but it is actually not that useful *) -} - -type call_id = - | Fun of A.fun_id * V.FunCallId.id - (** A "regular" function (i.e., a function which is not a primitive operation) *) - | Unop of E.unop - | Binop of E.binop -[@@deriving show, ord] - -type call = { - call_id : call_id; - abstractions : V.AbstractionId.id list; - type_params : T.ety list; - args : V.typed_value list; - args_places : mplace option list; (** Meta information *) - dest : V.symbolic_value; - dest_place : mplace option; (** Meta information *) -} - -(** Meta information, not necessary for synthesis but useful to guide it to - generate a pretty output. - *) - -type meta = - | Assignment of mplace * V.typed_value * mplace option - (** We generated an assignment (destination, assigned value, src) *) - -(** **Rk.:** here, {!expression} is not at all equivalent to the expressions - used in LLBC: they are a first step towards lambda-calculus expressions. - *) -type expression = - | Return of V.typed_value option - (** There are two cases: - - the AST is for a forward function: the typed value should contain - the value which was in the return variable - - the AST is for a backward function: the typed value should be [None] - *) - | Panic - | FunCall of call * expression - | EndAbstraction of V.abs * expression - | EvalGlobal of A.GlobalDeclId.id * V.symbolic_value * expression - (** Evaluate a global to a fresh symbolic value *) - | Expansion of mplace option * V.symbolic_value * expansion - (** Expansion of a symbolic value. - - The place is "meta": it gives the path to the symbolic value (if available) - which got expanded (this path is available when the symbolic expansion - comes from a path evaluation, during an assignment for instance). - We use it to compute meaningful names for the variables we introduce, - to prettify the generated code. - *) - | Meta of meta * expression (** Meta information *) - -and expansion = - | ExpandNoBranch of V.symbolic_expansion * expression - (** A symbolic expansion which doesn't generate a branching. - Includes: - - concrete expansion - - borrow expansion - *Doesn't* include: - - expansion of ADTs with one variant - *) - | ExpandAdt of - (T.VariantId.id option * V.symbolic_value list * expression) list - (** ADT expansion *) - | ExpandBool of expression * expression - (** A boolean expansion (i.e, an [if ... then ... else ...]) *) - | ExpandInt of - T.integer_type * (V.scalar_value * expression) list * expression - (** An integer expansion (i.e, a switch over an integer). The last - expression is for the "otherwise" branch. *) diff --git a/src/SymbolicToPure.ml b/src/SymbolicToPure.ml deleted file mode 100644 index de4fb4c1..00000000 --- a/src/SymbolicToPure.ml +++ /dev/null @@ -1,1824 +0,0 @@ -open Errors -open LlbcAstUtils -open Pure -open PureUtils -module Id = Identifiers -module S = SymbolicAst -module TA = TypesAnalysis -module L = Logging -module PP = PrintPure -module FA = FunsAnalysis - -(** The local logger *) -let log = L.symbolic_to_pure_log - -type config = { - filter_useless_back_calls : bool; - (** If [true], filter the useless calls to backward functions. - - The useless calls are calls to backward functions which have no outputs. - This case happens if the original Rust function only takes *shared* borrows - as inputs, and is thus pretty common. - - We are allowed to do this only because in this specific case, - the backward function fails *exactly* when the forward function fails - (they actually do exactly the same thing, the only difference being - that the forward function can potentially return a value), and upon - reaching the place where we should introduce a call to the backward - function, we know we have introduced a call to the forward function. - - Also note that in general, backward functions "do more things" than - forward functions, and have more opportunities to fail (even though - in the generated code, backward functions should fail exactly when - the forward functions fail). - - We might want to move this optimization to the micro-passes subsequent - to the translation from symbolic to pure, but it is really super easy - to do it when going from symbolic to pure. - Note that we later filter the useless *forward* calls in the micro-passes, - where it is more natural to do. - *) -} - -type type_context = { - llbc_type_decls : T.type_decl TypeDeclId.Map.t; - type_decls : type_decl TypeDeclId.Map.t; - (** We use this for type-checking (for sanity checks) when translating - values and functions. - This map is empty when we translate the types, then contains all - the translated types when we translate the functions. - *) - types_infos : TA.type_infos; (* TODO: rename to type_infos *) -} - -type fun_sig_named_outputs = { - sg : fun_sig; (** A function signature *) - output_names : string option list; - (** In case the signature is for a backward function, we may provides names - for the outputs. The reason is that the outputs of backward functions - come from (in case there are no nested borrows) borrows present in the - inputs of the original rust function. In this situation, we can use the - names of those inputs to name the outputs. Those names are very useful - to generate beautiful codes (we may need to introduce temporary variables - in the bodies of the backward functions to store the returned values, in - which case we use those names). - *) -} - -type fun_context = { - llbc_fun_decls : A.fun_decl A.FunDeclId.Map.t; - fun_sigs : fun_sig_named_outputs RegularFunIdMap.t; (** *) - fun_infos : FA.fun_info A.FunDeclId.Map.t; -} - -type global_context = { llbc_global_decls : A.global_decl A.GlobalDeclId.Map.t } - -(** Whenever we translate a function call or an ended abstraction, we - store the related information (this is useful when translating ended - children abstractions). - *) -type call_info = { - forward : S.call; - forward_inputs : texpression list; - (** Remember the list of inputs given to the forward function. - - Those inputs include the state input, if pertinent (in which case - it is the last input). - *) - backwards : (V.abs * texpression list) T.RegionGroupId.Map.t; - (** A map from region group id (i.e., backward function id) to - pairs (abstraction, additional arguments received by the backward function) - - TODO: remove? it is also in the bs_ctx ("abstractions" field) - *) -} - -(** Body synthesis context *) -type bs_ctx = { - type_context : type_context; - fun_context : fun_context; - global_context : global_context; - fun_decl : A.fun_decl; - bid : T.RegionGroupId.id option; (** TODO: rename *) - sg : fun_sig; - (** The function signature - useful in particular to translate [Panic] *) - sv_to_var : var V.SymbolicValueId.Map.t; - (** Whenever we encounter a new symbolic value (introduced because of - a symbolic expansion or upon ending an abstraction, for instance) - we introduce a new variable (with a let-binding). - *) - var_counter : VarId.generator; - state_var : VarId.id; - (** The current state variable, in case we use a state *) - forward_inputs : var list; - (** The input parameters for the forward function *) - backward_inputs : var list T.RegionGroupId.Map.t; - (** The input parameters for the backward functions *) - backward_outputs : var list T.RegionGroupId.Map.t; - (** The variables that the backward functions will output *) - calls : call_info V.FunCallId.Map.t; - (** The function calls we encountered so far *) - abstractions : (V.abs * texpression list) V.AbstractionId.Map.t; - (** The ended abstractions we encountered so far, with their additional input arguments *) -} - -let type_check_pattern (ctx : bs_ctx) (v : typed_pattern) : unit = - let env = VarId.Map.empty in - let ctx = - { - PureTypeCheck.type_decls = ctx.type_context.type_decls; - global_decls = ctx.global_context.llbc_global_decls; - env; - } - in - let _ = PureTypeCheck.check_typed_pattern ctx v in - () - -let type_check_texpression (ctx : bs_ctx) (e : texpression) : unit = - let env = VarId.Map.empty in - let ctx = - { - PureTypeCheck.type_decls = ctx.type_context.type_decls; - global_decls = ctx.global_context.llbc_global_decls; - env; - } - in - PureTypeCheck.check_texpression ctx e - -(* TODO: move *) -let bs_ctx_to_ast_formatter (ctx : bs_ctx) : Print.LlbcAst.ast_formatter = - Print.LlbcAst.fun_decl_to_ast_formatter ctx.type_context.llbc_type_decls - ctx.fun_context.llbc_fun_decls ctx.global_context.llbc_global_decls - ctx.fun_decl - -let bs_ctx_to_pp_ast_formatter (ctx : bs_ctx) : PrintPure.ast_formatter = - let type_params = ctx.fun_decl.signature.type_params in - let type_decls = ctx.type_context.llbc_type_decls in - let fun_decls = ctx.fun_context.llbc_fun_decls in - let global_decls = ctx.global_context.llbc_global_decls in - PrintPure.mk_ast_formatter type_decls fun_decls global_decls type_params - -let ty_to_string (ctx : bs_ctx) (ty : ty) : string = - let fmt = bs_ctx_to_pp_ast_formatter ctx in - let fmt = PrintPure.ast_to_type_formatter fmt in - PrintPure.ty_to_string fmt ty - -let type_decl_to_string (ctx : bs_ctx) (def : type_decl) : string = - let type_params = def.type_params in - let type_decls = ctx.type_context.llbc_type_decls in - let fmt = PrintPure.mk_type_formatter type_decls type_params in - PrintPure.type_decl_to_string fmt def - -let texpression_to_string (ctx : bs_ctx) (e : texpression) : string = - let fmt = bs_ctx_to_pp_ast_formatter ctx in - PrintPure.texpression_to_string fmt false "" " " e - -let fun_sig_to_string (ctx : bs_ctx) (sg : fun_sig) : string = - let type_params = sg.type_params in - let type_decls = ctx.type_context.llbc_type_decls in - let fun_decls = ctx.fun_context.llbc_fun_decls in - let global_decls = ctx.global_context.llbc_global_decls in - let fmt = - PrintPure.mk_ast_formatter type_decls fun_decls global_decls type_params - in - PrintPure.fun_sig_to_string fmt sg - -let fun_decl_to_string (ctx : bs_ctx) (def : Pure.fun_decl) : string = - let type_params = def.signature.type_params in - let type_decls = ctx.type_context.llbc_type_decls in - let fun_decls = ctx.fun_context.llbc_fun_decls in - let global_decls = ctx.global_context.llbc_global_decls in - let fmt = - PrintPure.mk_ast_formatter type_decls fun_decls global_decls type_params - in - PrintPure.fun_decl_to_string fmt def - -(* TODO: move *) -let abs_to_string (ctx : bs_ctx) (abs : V.abs) : string = - let fmt = bs_ctx_to_ast_formatter ctx in - let fmt = Print.LlbcAst.ast_to_value_formatter fmt in - let indent = "" in - let indent_incr = " " in - Print.Values.abs_to_string fmt indent indent_incr abs - -let get_instantiated_fun_sig (fun_id : A.fun_id) - (back_id : T.RegionGroupId.id option) (tys : ty list) (ctx : bs_ctx) : - inst_fun_sig = - (* Lookup the non-instantiated function signature *) - let sg = - (RegularFunIdMap.find (fun_id, back_id) ctx.fun_context.fun_sigs).sg - in - (* Create the substitution *) - let tsubst = make_type_subst sg.type_params tys in - (* Apply *) - fun_sig_substitute tsubst sg - -let bs_ctx_lookup_llbc_type_decl (id : TypeDeclId.id) (ctx : bs_ctx) : - T.type_decl = - TypeDeclId.Map.find id ctx.type_context.llbc_type_decls - -let bs_ctx_lookup_llbc_fun_decl (id : A.FunDeclId.id) (ctx : bs_ctx) : - A.fun_decl = - A.FunDeclId.Map.find id ctx.fun_context.llbc_fun_decls - -(* TODO: move *) -let bs_ctx_lookup_local_function_sig (def_id : A.FunDeclId.id) - (back_id : T.RegionGroupId.id option) (ctx : bs_ctx) : fun_sig = - let id = (A.Regular def_id, back_id) in - (RegularFunIdMap.find id ctx.fun_context.fun_sigs).sg - -let bs_ctx_register_forward_call (call_id : V.FunCallId.id) (forward : S.call) - (args : texpression list) (ctx : bs_ctx) : bs_ctx = - let calls = ctx.calls in - assert (not (V.FunCallId.Map.mem call_id calls)); - let info = - { forward; forward_inputs = args; backwards = T.RegionGroupId.Map.empty } - in - let calls = V.FunCallId.Map.add call_id info calls in - { ctx with calls } - -(** [back_args]: the *additional* list of inputs received by the backward function *) -let bs_ctx_register_backward_call (abs : V.abs) (back_args : texpression list) - (ctx : bs_ctx) : bs_ctx * fun_id = - (* Insert the abstraction in the call informations *) - let back_id = abs.back_id in - let info = V.FunCallId.Map.find abs.call_id ctx.calls in - assert (not (T.RegionGroupId.Map.mem back_id info.backwards)); - let backwards = - T.RegionGroupId.Map.add back_id (abs, back_args) info.backwards - in - let info = { info with backwards } in - let calls = V.FunCallId.Map.add abs.call_id info ctx.calls in - (* Insert the abstraction in the abstractions map *) - let abstractions = ctx.abstractions in - assert (not (V.AbstractionId.Map.mem abs.abs_id abstractions)); - let abstractions = - V.AbstractionId.Map.add abs.abs_id (abs, back_args) abstractions - in - (* Retrieve the fun_id *) - let fun_id = - match info.forward.call_id with - | S.Fun (fid, _) -> Regular (fid, Some abs.back_id) - | S.Unop _ | S.Binop _ -> raise (Failure "Unreachable") - in - (* Update the context and return *) - ({ ctx with calls; abstractions }, fun_id) - -let rec translate_sty (ty : T.sty) : ty = - let translate = translate_sty in - match ty with - | T.Adt (type_id, regions, tys) -> ( - (* Can't translate types with regions for now *) - assert (regions = []); - let tys = List.map translate tys in - match type_id with - | T.AdtId adt_id -> Adt (AdtId adt_id, tys) - | T.Tuple -> mk_simpl_tuple_ty tys - | T.Assumed aty -> ( - match aty with - | T.Vec -> Adt (Assumed Vec, tys) - | T.Option -> Adt (Assumed Option, tys) - | T.Box -> ( - (* Eliminate the boxes *) - match tys with - | [ ty ] -> ty - | _ -> - failwith - "Box/vec/option type with incorrect number of arguments"))) - | TypeVar vid -> TypeVar vid - | Bool -> Bool - | Char -> Char - | Never -> raise (Failure "Unreachable") - | Integer int_ty -> Integer int_ty - | Str -> Str - | Array ty -> Array (translate ty) - | Slice ty -> Slice (translate ty) - | Ref (_, rty, _) -> translate rty - -let translate_field (f : T.field) : field = - let field_name = f.field_name in - let field_ty = translate_sty f.field_ty in - { field_name; field_ty } - -let translate_fields (fl : T.field list) : field list = - List.map translate_field fl - -let translate_variant (v : T.variant) : variant = - let variant_name = v.variant_name in - let fields = translate_fields v.fields in - { variant_name; fields } - -let translate_variants (vl : T.variant list) : variant list = - List.map translate_variant vl - -(** Translate a type def kind to IM *) -let translate_type_decl_kind (kind : T.type_decl_kind) : type_decl_kind = - match kind with - | T.Struct fields -> Struct (translate_fields fields) - | T.Enum variants -> Enum (translate_variants variants) - | T.Opaque -> Opaque - -(** Translate a type definition from IM - - TODO: this is not symbolic to pure but IM to pure. Still, I don't see the - point of moving this definition for now. - *) -let translate_type_decl (def : T.type_decl) : type_decl = - (* Translate *) - let def_id = def.T.def_id in - let name = def.name in - (* Can't translate types with regions for now *) - assert (def.region_params = []); - let type_params = def.type_params in - let kind = translate_type_decl_kind def.T.kind in - { def_id; name; type_params; kind } - -(** Translate a type, seen as an input/output of a forward function - (preserve all borrows, etc.) -*) - -let rec translate_fwd_ty (types_infos : TA.type_infos) (ty : 'r T.ty) : ty = - let translate = translate_fwd_ty types_infos in - match ty with - | T.Adt (type_id, regions, tys) -> ( - (* Can't translate types with regions for now *) - assert (regions = []); - (* Translate the type parameters *) - let t_tys = List.map translate tys in - (* Eliminate boxes and simplify tuples *) - match type_id with - | AdtId _ | T.Assumed (T.Vec | T.Option) -> - (* No general parametricity for now *) - assert (not (List.exists (TypesUtils.ty_has_borrows types_infos) tys)); - let type_id = - match type_id with - | AdtId adt_id -> AdtId adt_id - | T.Assumed T.Vec -> Assumed Vec - | T.Assumed T.Option -> Assumed Option - | _ -> raise (Failure "Unreachable") - in - Adt (type_id, t_tys) - | Tuple -> - (* Note that if there is exactly one type, [mk_simpl_tuple_ty] is the - identity *) - mk_simpl_tuple_ty t_tys - | T.Assumed T.Box -> ( - (* We eliminate boxes *) - (* No general parametricity for now *) - assert (not (List.exists (TypesUtils.ty_has_borrows types_infos) tys)); - match t_tys with - | [ bty ] -> bty - | _ -> - failwith - "Unreachable: box/vec/option receives exactly one type \ - parameter")) - | TypeVar vid -> TypeVar vid - | Bool -> Bool - | Char -> Char - | Never -> raise (Failure "Unreachable") - | Integer int_ty -> Integer int_ty - | Str -> Str - | Array ty -> - assert (not (TypesUtils.ty_has_borrows types_infos ty)); - Array (translate ty) - | Slice ty -> - assert (not (TypesUtils.ty_has_borrows types_infos ty)); - Slice (translate ty) - | Ref (_, rty, _) -> translate rty - -(** Simply calls [translate_fwd_ty] *) -let ctx_translate_fwd_ty (ctx : bs_ctx) (ty : 'r T.ty) : ty = - let types_infos = ctx.type_context.types_infos in - translate_fwd_ty types_infos ty - -(** Translate a type, when some regions may have ended. - - We return an option, because the translated type may be empty. - - [inside_mut]: are we inside a mutable borrow? - *) -let rec translate_back_ty (types_infos : TA.type_infos) - (keep_region : 'r -> bool) (inside_mut : bool) (ty : 'r T.ty) : ty option = - let translate = translate_back_ty types_infos keep_region inside_mut in - (* A small helper for "leave" types *) - let wrap ty = if inside_mut then Some ty else None in - match ty with - | T.Adt (type_id, _, tys) -> ( - match type_id with - | T.AdtId _ | Assumed (T.Vec | T.Option) -> - (* Don't accept ADTs (which are not tuples) with borrows for now *) - assert (not (TypesUtils.ty_has_borrows types_infos ty)); - let type_id = - match type_id with - | T.AdtId id -> AdtId id - | T.Assumed T.Vec -> Assumed Vec - | T.Assumed T.Option -> Assumed Option - | T.Tuple | T.Assumed T.Box -> raise (Failure "Unreachable") - in - if inside_mut then - let tys_t = List.filter_map translate tys in - Some (Adt (type_id, tys_t)) - else None - | Assumed T.Box -> ( - (* Don't accept ADTs (which are not tuples) with borrows for now *) - assert (not (TypesUtils.ty_has_borrows types_infos ty)); - (* Eliminate the box *) - match tys with - | [ bty ] -> translate bty - | _ -> - failwith "Unreachable: boxes receive exactly one type parameter") - | T.Tuple -> ( - (* Tuples can contain borrows (which we eliminated) *) - let tys_t = List.filter_map translate tys in - match tys_t with - | [] -> None - | _ -> - (* Note that if there is exactly one type, [mk_simpl_tuple_ty] - * is the identity *) - Some (mk_simpl_tuple_ty tys_t))) - | TypeVar vid -> wrap (TypeVar vid) - | Bool -> wrap Bool - | Char -> wrap Char - | Never -> raise (Failure "Unreachable") - | Integer int_ty -> wrap (Integer int_ty) - | Str -> wrap Str - | Array ty -> ( - assert (not (TypesUtils.ty_has_borrows types_infos ty)); - match translate ty with None -> None | Some ty -> Some (Array ty)) - | Slice ty -> ( - assert (not (TypesUtils.ty_has_borrows types_infos ty)); - match translate ty with None -> None | Some ty -> Some (Slice ty)) - | Ref (r, rty, rkind) -> ( - match rkind with - | T.Shared -> - (* Ignore shared references, unless we are below a mutable borrow *) - if inside_mut then translate rty else None - | T.Mut -> - (* Dive in, remembering the fact that we are inside a mutable borrow *) - let inside_mut = true in - if keep_region r then - translate_back_ty types_infos keep_region inside_mut rty - else None) - -(** Simply calls [translate_back_ty] *) -let ctx_translate_back_ty (ctx : bs_ctx) (keep_region : 'r -> bool) - (inside_mut : bool) (ty : 'r T.ty) : ty option = - let types_infos = ctx.type_context.types_infos in - translate_back_ty types_infos keep_region inside_mut ty - -(** List the ancestors of an abstraction *) -let list_ancestor_abstractions_ids (ctx : bs_ctx) (abs : V.abs) : - V.AbstractionId.id list = - (* We could do something more "elegant" without references, but it is - * so much simpler to use references... *) - let abs_set = ref V.AbstractionId.Set.empty in - let rec gather (abs_id : V.AbstractionId.id) : unit = - if V.AbstractionId.Set.mem abs_id !abs_set then () - else ( - abs_set := V.AbstractionId.Set.add abs_id !abs_set; - let abs, _ = V.AbstractionId.Map.find abs_id ctx.abstractions in - List.iter gather abs.original_parents) - in - List.iter gather abs.original_parents; - let ids = !abs_set in - (* List the ancestors, in the proper order *) - let call_info = V.FunCallId.Map.find abs.call_id ctx.calls in - List.filter - (fun id -> V.AbstractionId.Set.mem id ids) - call_info.forward.abstractions - -let list_ancestor_abstractions (ctx : bs_ctx) (abs : V.abs) : - (V.abs * texpression list) list = - let abs_ids = list_ancestor_abstractions_ids ctx abs in - List.map (fun id -> V.AbstractionId.Map.find id ctx.abstractions) abs_ids - -(** Small utility. *) -let get_fun_effect_info (fun_infos : FA.fun_info A.FunDeclId.Map.t) - (fun_id : A.fun_id) (gid : T.RegionGroupId.id option) : fun_effect_info = - match fun_id with - | A.Regular fid -> - let info = A.FunDeclId.Map.find fid fun_infos in - let input_state = info.stateful in - let output_state = input_state && gid = None in - { can_fail = info.can_fail; input_state; output_state } - | A.Assumed aid -> - { - can_fail = Assumed.assumed_can_fail aid; - input_state = false; - output_state = false; - } - -(** Translate a function signature. - - Note that the function also takes a list of names for the inputs, and - computes, for every output for the backward functions, a corresponding - name (outputs for backward functions come from borrows in the inputs - of the forward function). - *) -let translate_fun_sig (fun_infos : FA.fun_info A.FunDeclId.Map.t) - (fun_id : A.fun_id) (types_infos : TA.type_infos) (sg : A.fun_sig) - (input_names : string option list) (bid : T.RegionGroupId.id option) : - fun_sig_named_outputs = - (* Retrieve the list of parent backward functions *) - let gid, parents = - match bid with - | None -> (None, T.RegionGroupId.Set.empty) - | Some bid -> - let parents = list_parent_region_groups sg bid in - (Some bid, parents) - in - (* List the inputs for: - * - the forward function - * - the parent backward functions, in proper order - * - the current backward function (if it is a backward function) - *) - let fwd_inputs = List.map (translate_fwd_ty types_infos) sg.inputs in - (* For the backward functions: for now we don't supported nested borrows, - * so just check that there aren't parent regions *) - assert (T.RegionGroupId.Set.is_empty parents); - (* Small helper to translate types for backward functions *) - let translate_back_ty_for_gid (gid : T.RegionGroupId.id) : T.sty -> ty option - = - let rg = T.RegionGroupId.nth sg.regions_hierarchy gid in - let regions = T.RegionVarId.Set.of_list rg.regions in - let keep_region r = - match r with - | T.Static -> raise Unimplemented - | T.Var r -> T.RegionVarId.Set.mem r regions - in - let inside_mut = false in - translate_back_ty types_infos keep_region inside_mut - in - (* Compute the additinal inputs for the current function, if it is a backward - * function *) - let back_inputs = - match gid with - | None -> [] - | Some gid -> - (* For now, we don't allow nested borrows, so the additional inputs to the - backward function can only come from borrows that were returned like - in (for the backward function we introduce for 'a): - {[ - fn f<'a>(...) -> &'a mut u32; - ]} - Upon ending the abstraction for 'a, we need to get back the borrow - the function returned. - *) - List.filter_map (translate_back_ty_for_gid gid) [ sg.output ] - in - (* Does the function take a state as input, does it return a state and can - * it fail? *) - let effect_info = get_fun_effect_info fun_infos fun_id bid in - (* *) - let state_ty = if effect_info.input_state then [ mk_state_ty ] else [] in - (* Concatenate the inputs, in the following order: - * - forward inputs - * - state input - * - backward inputs - *) - let inputs = List.concat [ fwd_inputs; state_ty; back_inputs ] in - (* Outputs *) - let output_names, doutputs = - match gid with - | None -> - (* This is a forward function: there is one (unnamed) output *) - ([ None ], [ translate_fwd_ty types_infos sg.output ]) - | Some gid -> - (* This is a backward function: there might be several outputs. - The outputs are the borrows inside the regions of the abstractions - and which are present in the input values. For instance, see: - {[ - fn f<'a>(x : &'a mut u32) -> ...; - ]} - Upon ending the abstraction for 'a, we give back the borrow which - was consumed through the [x] parameter. - *) - let outputs = - List.map - (fun (name, input_ty) -> - (name, translate_back_ty_for_gid gid input_ty)) - (List.combine input_names sg.inputs) - in - (* Filter *) - let outputs = - List.filter (fun (_, opt_ty) -> Option.is_some opt_ty) outputs - in - let outputs = - List.map (fun (name, opt_ty) -> (name, Option.get opt_ty)) outputs - in - List.split outputs - in - (* Create the return type *) - let output = - (* Group the outputs together *) - let output = mk_simpl_tuple_ty doutputs in - (* Add the output state *) - let output = - if effect_info.output_state then mk_simpl_tuple_ty [ mk_state_ty; output ] - else output - in - (* Wrap in a result type *) - if effect_info.can_fail then mk_result_ty output else output - in - (* Type parameters *) - let type_params = sg.type_params in - (* Return *) - let info = - { - num_fwd_inputs = List.length fwd_inputs; - num_back_inputs = - (if bid = None then None else Some (List.length back_inputs)); - effect_info; - } - in - let sg = { type_params; inputs; output; doutputs; info } in - { sg; output_names } - -let bs_ctx_fresh_state_var (ctx : bs_ctx) : bs_ctx * typed_pattern = - (* Generate the fresh variable *) - let id, var_counter = VarId.fresh ctx.var_counter in - let var = - { id; basename = Some ConstStrings.state_basename; ty = mk_state_ty } - in - let state_var = mk_typed_pattern_from_var var None in - (* Update the context *) - let ctx = { ctx with var_counter; state_var = id } in - (* Return *) - (ctx, state_var) - -let fresh_named_var_for_symbolic_value (basename : string option) - (sv : V.symbolic_value) (ctx : bs_ctx) : bs_ctx * var = - (* Generate the fresh variable *) - let id, var_counter = VarId.fresh ctx.var_counter in - let ty = ctx_translate_fwd_ty ctx sv.sv_ty in - let var = { id; basename; ty } in - (* Insert in the map *) - let sv_to_var = V.SymbolicValueId.Map.add sv.sv_id var ctx.sv_to_var in - (* Update the context *) - let ctx = { ctx with var_counter; sv_to_var } in - (* Return *) - (ctx, var) - -let fresh_var_for_symbolic_value (sv : V.symbolic_value) (ctx : bs_ctx) : - bs_ctx * var = - fresh_named_var_for_symbolic_value None sv ctx - -let fresh_vars_for_symbolic_values (svl : V.symbolic_value list) (ctx : bs_ctx) - : bs_ctx * var list = - List.fold_left_map (fun ctx sv -> fresh_var_for_symbolic_value sv ctx) ctx svl - -let fresh_named_vars_for_symbolic_values - (svl : (string option * V.symbolic_value) list) (ctx : bs_ctx) : - bs_ctx * var list = - List.fold_left_map - (fun ctx (name, sv) -> fresh_named_var_for_symbolic_value name sv ctx) - ctx svl - -(** This generates a fresh variable **which is not to be linked to any symbolic value** *) -let fresh_var (basename : string option) (ty : ty) (ctx : bs_ctx) : bs_ctx * var - = - (* Generate the fresh variable *) - let id, var_counter = VarId.fresh ctx.var_counter in - let var = { id; basename; ty } in - (* Update the context *) - let ctx = { ctx with var_counter } in - (* Return *) - (ctx, var) - -let fresh_vars (vars : (string option * ty) list) (ctx : bs_ctx) : - bs_ctx * var list = - List.fold_left_map (fun ctx (name, ty) -> fresh_var name ty ctx) ctx vars - -let lookup_var_for_symbolic_value (sv : V.symbolic_value) (ctx : bs_ctx) : var = - V.SymbolicValueId.Map.find sv.sv_id ctx.sv_to_var - -(** Peel boxes as long as the value is of the form [Box<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/src/SynthesizeSymbolic.ml b/src/SynthesizeSymbolic.ml deleted file mode 100644 index a2256bdd..00000000 --- a/src/SynthesizeSymbolic.ml +++ /dev/null @@ -1,156 +0,0 @@ -module C = Collections -module T = Types -module V = Values -module E = Expressions -module A = LlbcAst -open SymbolicAst - -let mk_mplace (p : E.place) (ctx : Contexts.eval_ctx) : mplace = - let bv = Contexts.ctx_lookup_binder ctx p.var_id in - { bv; projection = p.projection } - -let mk_opt_mplace (p : E.place option) (ctx : Contexts.eval_ctx) : mplace option - = - match p with None -> None | Some p -> Some (mk_mplace p ctx) - -let mk_opt_place_from_op (op : E.operand) (ctx : Contexts.eval_ctx) : - mplace option = - match op with - | E.Copy p | E.Move p -> Some (mk_mplace p ctx) - | E.Constant _ -> None - -let synthesize_symbolic_expansion (sv : V.symbolic_value) - (place : mplace option) (seel : V.symbolic_expansion option list) - (exprl : expression list option) : expression option = - match exprl with - | None -> None - | Some exprl -> - let ls = List.combine seel exprl in - (* Match on the symbolic value type to know which can of expansion happened *) - let expansion = - match sv.V.sv_ty with - | T.Bool -> ( - (* Boolean expansion: there should be two branches *) - match ls with - | [ - (Some (V.SeConcrete (V.Bool true)), true_exp); - (Some (V.SeConcrete (V.Bool false)), false_exp); - ] -> - ExpandBool (true_exp, false_exp) - | _ -> failwith "Ill-formed boolean expansion") - | T.Integer int_ty -> - (* Switch over an integer: split between the "regular" branches - and the "otherwise" branch (which should be the last branch) *) - let branches, otherwise = C.List.pop_last ls in - (* For all the regular branches, the symbolic value should have - * been expanded to a constant *) - let get_scalar (see : V.symbolic_expansion option) : V.scalar_value - = - match see with - | Some (V.SeConcrete (V.Scalar cv)) -> - assert (cv.V.int_ty = int_ty); - cv - | _ -> failwith "Unreachable" - in - let branches = - List.map (fun (see, exp) -> (get_scalar see, exp)) branches - in - (* For the otherwise branch, the symbolic value should have been left - * unchanged *) - let otherwise_see, otherwise = otherwise in - assert (otherwise_see = None); - (* Return *) - ExpandInt (int_ty, branches, otherwise) - | T.Adt (_, _, _) -> - (* Branching: it is necessarily an enumeration expansion *) - let get_variant (see : V.symbolic_expansion option) : - T.VariantId.id option * V.symbolic_value list = - match see with - | Some (V.SeAdt (vid, fields)) -> (vid, fields) - | _ -> failwith "Ill-formed branching ADT expansion" - in - let exp = - List.map - (fun (see, exp) -> - let vid, fields = get_variant see in - (vid, fields, exp)) - ls - in - ExpandAdt exp - | T.Ref (_, _, _) -> ( - (* Reference expansion: there should be one branch *) - match ls with - | [ (Some see, exp) ] -> ExpandNoBranch (see, exp) - | _ -> failwith "Ill-formed borrow expansion") - | T.TypeVar _ | Char | Never | Str | Array _ | Slice _ -> - failwith "Ill-formed symbolic expansion" - in - Some (Expansion (place, sv, expansion)) - -let synthesize_symbolic_expansion_no_branching (sv : V.symbolic_value) - (place : mplace option) (see : V.symbolic_expansion) - (expr : expression option) : expression option = - let exprl = match expr with None -> None | Some expr -> Some [ expr ] in - synthesize_symbolic_expansion sv place [ Some see ] exprl - -let synthesize_function_call (call_id : call_id) - (abstractions : V.AbstractionId.id list) (type_params : T.ety list) - (args : V.typed_value list) (args_places : mplace option list) - (dest : V.symbolic_value) (dest_place : mplace option) - (expr : expression option) : expression option = - match expr with - | None -> None - | Some expr -> - let call = - { - call_id; - abstractions; - type_params; - args; - dest; - args_places; - dest_place; - } - in - Some (FunCall (call, expr)) - -let synthesize_global_eval (gid : A.GlobalDeclId.id) (dest : V.symbolic_value) - (expr : expression option) : expression option = - match expr with None -> None | Some e -> Some (EvalGlobal (gid, dest, e)) - -let synthesize_regular_function_call (fun_id : A.fun_id) - (call_id : V.FunCallId.id) (abstractions : V.AbstractionId.id list) - (type_params : T.ety list) (args : V.typed_value list) - (args_places : mplace option list) (dest : V.symbolic_value) - (dest_place : mplace option) (expr : expression option) : expression option - = - synthesize_function_call - (Fun (fun_id, call_id)) - abstractions type_params args args_places dest dest_place expr - -let synthesize_unary_op (unop : E.unop) (arg : V.typed_value) - (arg_place : mplace option) (dest : V.symbolic_value) - (dest_place : mplace option) (expr : expression option) : expression option - = - synthesize_function_call (Unop unop) [] [] [ arg ] [ arg_place ] dest - dest_place expr - -let synthesize_binary_op (binop : E.binop) (arg0 : V.typed_value) - (arg0_place : mplace option) (arg1 : V.typed_value) - (arg1_place : mplace option) (dest : V.symbolic_value) - (dest_place : mplace option) (expr : expression option) : expression option - = - synthesize_function_call (Binop binop) [] [] [ arg0; arg1 ] - [ arg0_place; arg1_place ] dest dest_place expr - -let synthesize_end_abstraction (abs : V.abs) (expr : expression option) : - expression option = - match expr with - | None -> None - | Some expr -> Some (EndAbstraction (abs, expr)) - -let synthesize_assignment (lplace : mplace) (rvalue : V.typed_value) - (rplace : mplace option) (expr : expression option) : expression option = - match expr with - | None -> None - | Some expr -> Some (Meta (Assignment (lplace, rvalue, rplace), expr)) diff --git a/src/Translate.ml b/src/Translate.ml deleted file mode 100644 index 8f3b94c4..00000000 --- a/src/Translate.ml +++ /dev/null @@ -1,871 +0,0 @@ -open InterpreterStatements -open Interpreter -module L = Logging -module T = Types -module A = LlbcAst -module SA = SymbolicAst -module Micro = PureMicroPasses -open PureUtils -open TranslateCore - -(** The local logger *) -let log = TranslateCore.log - -type config = { - eval_config : Contexts.partial_config; - mp_config : Micro.config; - use_state : bool; - (** Controls whether we need to use a state to model the external world - (I/O, for instance). - *) - split_files : bool; - (** Controls whether we split the generated definitions between different - files for the types, clauses and functions, or if we group them in - one file. - *) - test_unit_functions : bool; - (** If true, insert tests in the generated files to check that the - unit functions normalize to [Success _]. - - For instance, in F* it generates code like this: - {[ - let _ = assert_norm (FUNCTION () = Success ()) - ]} - *) - extract_decreases_clauses : bool; - (** If [true], insert [decreases] clauses for all the recursive definitions. - - The body of such clauses must be defined by the user. - *) - extract_template_decreases_clauses : bool; - (** In order to help the user, we can generate "template" decrease clauses - (i.e., definitions with proper signatures but dummy bodies) in a - dedicated file. - *) -} - -(** The result of running the symbolic interpreter on a function: - - the list of symbolic values used for the input values - - the generated symbolic AST -*) -type symbolic_fun_translation = V.symbolic_value list * SA.expression - -(** Execute the symbolic interpreter on a function to generate a list of symbolic ASTs, - for the forward function and the backward functions. -*) -let translate_function_to_symbolics (config : C.partial_config) - (trans_ctx : trans_ctx) (fdef : A.fun_decl) : - (symbolic_fun_translation * symbolic_fun_translation list) option = - (* Debug *) - log#ldebug - (lazy - ("translate_function_to_symbolics: " - ^ Print.fun_name_to_string fdef.A.name)); - - let { type_context; fun_context; global_context } = trans_ctx in - let fun_context = { C.fun_decls = fun_context.fun_decls } in - - match fdef.body with - | None -> None - | Some _ -> - (* Evaluate *) - let synthesize = true in - let evaluate gid = - let inputs, symb = - evaluate_function_symbolic config synthesize type_context fun_context - global_context fdef gid - in - (inputs, Option.get symb) - in - (* Execute the forward function *) - let forward = evaluate None in - (* Execute the backward functions *) - let backwards = - T.RegionGroupId.mapi - (fun gid _ -> evaluate (Some gid)) - fdef.signature.regions_hierarchy - in - - (* Return *) - Some (forward, backwards) - -(** Translate a function, by generating its forward and backward translations. - - [fun_sigs]: maps the forward/backward functions to their signatures. In case - of backward functions, we also provide names for the outputs. - TODO: maybe we should introduce a record for this. -*) -let translate_function_to_pure (config : C.partial_config) - (mp_config : Micro.config) (trans_ctx : trans_ctx) - (fun_sigs : SymbolicToPure.fun_sig_named_outputs RegularFunIdMap.t) - (pure_type_decls : Pure.type_decl Pure.TypeDeclId.Map.t) (fdef : A.fun_decl) - : pure_fun_translation = - (* Debug *) - log#ldebug - (lazy - ("translate_function_to_pure: " ^ Print.fun_name_to_string fdef.A.name)); - - let { type_context; fun_context; global_context } = trans_ctx in - let def_id = fdef.def_id in - - (* Compute the symbolic ASTs, if the function is transparent *) - let symbolic_trans = translate_function_to_symbolics config trans_ctx fdef in - let symbolic_forward, symbolic_backwards = - match symbolic_trans with - | None -> (None, None) - | Some (fwd, backs) -> (Some fwd, Some backs) - in - - (* Convert the symbolic ASTs to pure ASTs: *) - - (* Initialize the context *) - let forward_sig = RegularFunIdMap.find (A.Regular def_id, None) fun_sigs in - let sv_to_var = V.SymbolicValueId.Map.empty in - let var_counter = Pure.VarId.generator_zero in - let state_var, var_counter = Pure.VarId.fresh var_counter in - let calls = V.FunCallId.Map.empty in - let abstractions = V.AbstractionId.Map.empty in - let type_context = - { - SymbolicToPure.types_infos = type_context.type_infos; - llbc_type_decls = type_context.type_decls; - type_decls = pure_type_decls; - } - in - let fun_context = - { - SymbolicToPure.llbc_fun_decls = fun_context.fun_decls; - fun_sigs; - fun_infos = fun_context.fun_infos; - } - in - let global_context = - { SymbolicToPure.llbc_global_decls = global_context.global_decls } - in - let ctx = - { - SymbolicToPure.bid = None; - (* Dummy for now *) - sg = forward_sig.sg; - (* Will need to be updated for the backward functions *) - sv_to_var; - var_counter; - state_var; - type_context; - fun_context; - global_context; - fun_decl = fdef; - forward_inputs = []; - (* Empty for now *) - backward_inputs = T.RegionGroupId.Map.empty; - (* Empty for now *) - backward_outputs = T.RegionGroupId.Map.empty; - (* Empty for now *) - calls; - abstractions; - } - in - - (* We need to initialize the input/output variables *) - let num_forward_inputs = List.length fdef.signature.inputs in - let add_forward_inputs input_svs ctx = - match fdef.body with - | None -> ctx - | Some body -> - let forward_input_vars = LlbcAstUtils.fun_body_get_input_vars body in - let forward_input_varnames = - List.map (fun (v : A.var) -> v.name) forward_input_vars - in - let input_svs = List.combine forward_input_varnames input_svs in - let ctx, forward_inputs = - SymbolicToPure.fresh_named_vars_for_symbolic_values input_svs ctx - in - { ctx with forward_inputs } - in - - (* The symbolic to pure config *) - let sp_config = - { - SymbolicToPure.filter_useless_back_calls = - mp_config.filter_useless_monadic_calls; - } - in - - (* Translate the forward function *) - let pure_forward = - match symbolic_forward with - | None -> SymbolicToPure.translate_fun_decl sp_config ctx None - | Some (fwd_svs, fwd_ast) -> - SymbolicToPure.translate_fun_decl sp_config - (add_forward_inputs fwd_svs ctx) - (Some fwd_ast) - in - - (* Translate the backward functions *) - let translate_backward (rg : T.region_var_group) : Pure.fun_decl = - (* For the backward inputs/outputs initialization: we use the fact that - * there are no nested borrows for now, and so that the region groups - * can't have parents *) - assert (rg.parents = []); - let back_id = rg.id in - - match symbolic_backwards with - | None -> - (* Initialize the context - note that the ret_ty is not really - * useful as we don't translate a body *) - let backward_sg = - RegularFunIdMap.find (A.Regular def_id, Some back_id) fun_sigs - in - let ctx = { ctx with bid = Some back_id; sg = backward_sg.sg } in - - (* Translate *) - SymbolicToPure.translate_fun_decl sp_config ctx None - | Some symbolic_backwards -> - let input_svs, symbolic = - T.RegionGroupId.nth symbolic_backwards back_id - in - let ctx = add_forward_inputs input_svs ctx in - (* TODO: the computation of the backward inputs is a bit awckward... *) - let backward_sg = - RegularFunIdMap.find (A.Regular def_id, Some back_id) fun_sigs - in - (* We need to ignore the forward inputs, and the state input (if there is) *) - let fun_info = - SymbolicToPure.get_fun_effect_info fun_context.fun_infos - (A.Regular def_id) (Some back_id) - in - let _, backward_inputs = - Collections.List.split_at backward_sg.sg.inputs - (num_forward_inputs + if fun_info.input_state then 1 else 0) - in - (* As we forbid nested borrows, the additional inputs for the backward - * functions come from the borrows in the return value of the rust function: - * we thus use the name "ret" for those inputs *) - let backward_inputs = - List.map (fun ty -> (Some "ret", ty)) backward_inputs - in - let ctx, backward_inputs = - SymbolicToPure.fresh_vars backward_inputs ctx - in - (* The outputs for the backward functions, however, come from borrows - * present in the input values of the rust function: for those we reuse - * the names of the input values. *) - let backward_outputs = - List.combine backward_sg.output_names backward_sg.sg.doutputs - in - let ctx, backward_outputs = - SymbolicToPure.fresh_vars backward_outputs ctx - in - let backward_inputs = - T.RegionGroupId.Map.singleton back_id backward_inputs - in - let backward_outputs = - T.RegionGroupId.Map.singleton back_id backward_outputs - in - - (* Put everything in the context *) - let ctx = - { - ctx with - bid = Some back_id; - sg = backward_sg.sg; - backward_inputs; - backward_outputs; - } - in - - (* Translate *) - SymbolicToPure.translate_fun_decl sp_config ctx (Some symbolic) - in - let pure_backwards = - List.map translate_backward fdef.signature.regions_hierarchy - in - - (* Return *) - (pure_forward, pure_backwards) - -let translate_module_to_pure (config : C.partial_config) - (mp_config : Micro.config) (use_state : bool) (crate : Crates.llbc_crate) : - trans_ctx * Pure.type_decl list * (bool * pure_fun_translation) list = - (* Debug *) - log#ldebug (lazy "translate_module_to_pure"); - - (* Compute the type and function contexts *) - let type_context, fun_context, global_context = - compute_type_fun_global_contexts crate - in - let fun_infos = - FA.analyze_module crate fun_context.C.fun_decls - global_context.C.global_decls use_state - in - let fun_context = { fun_decls = fun_context.fun_decls; fun_infos } in - let trans_ctx = { type_context; fun_context; global_context } in - - (* Translate all the type definitions *) - let type_decls = SymbolicToPure.translate_type_decls crate.types in - - (* Compute the type definition map *) - let type_decls_map = - Pure.TypeDeclId.Map.of_list - (List.map (fun (def : Pure.type_decl) -> (def.def_id, def)) type_decls) - in - - (* Translate all the function *signatures* *) - let assumed_sigs = - List.map - (fun (id, sg, _, _) -> - (A.Assumed id, List.map (fun _ -> None) (sg : A.fun_sig).inputs, sg)) - Assumed.assumed_infos - in - let local_sigs = - List.map - (fun (fdef : A.fun_decl) -> - let input_names = - match fdef.body with - | None -> List.map (fun _ -> None) fdef.signature.inputs - | Some body -> - List.map - (fun (v : A.var) -> v.name) - (LlbcAstUtils.fun_body_get_input_vars body) - in - (A.Regular fdef.def_id, input_names, fdef.signature)) - crate.functions - in - let sigs = List.append assumed_sigs local_sigs in - let fun_sigs = - SymbolicToPure.translate_fun_signatures fun_context.fun_infos - type_context.type_infos sigs - in - - (* Translate all the *transparent* functions *) - let pure_translations = - List.map - (translate_function_to_pure config mp_config trans_ctx fun_sigs - type_decls_map) - crate.functions - in - - (* Apply the micro-passes *) - let pure_translations = - List.map - (Micro.apply_passes_to_pure_fun_translation mp_config trans_ctx) - pure_translations - in - - (* Return *) - (trans_ctx, type_decls, pure_translations) - -(** Extraction context *) -type gen_ctx = { - crate : Crates.llbc_crate; - extract_ctx : PureToExtract.extraction_ctx; - trans_types : Pure.type_decl Pure.TypeDeclId.Map.t; - trans_funs : (bool * pure_fun_translation) A.FunDeclId.Map.t; - functions_with_decreases_clause : A.FunDeclId.Set.t; -} - -type gen_config = { - mp_config : Micro.config; - use_state : bool; - extract_types : bool; - extract_decreases_clauses : bool; - extract_template_decreases_clauses : bool; - extract_fun_decls : bool; - extract_transparent : bool; - (** If [true], extract the transparent declarations, otherwise ignore. *) - extract_opaque : bool; - (** If [true], extract the opaque declarations, otherwise ignore. *) - extract_state_type : bool; - (** If [true], generate a definition/declaration for the state type *) - interface : bool; - (** [true] if we generate an interface file, [false] otherwise. - For now, this only impacts whether we use [val] or [assume val] for the - opaque definitions. In the future, we might want to extract all the - declarations in an interface file, together with an implementation file - if needed. - *) - test_unit_functions : bool; -} - -(** Returns the pair: (has opaque type decls, has opaque fun decls) *) -let module_has_opaque_decls (ctx : gen_ctx) : bool * bool = - let has_opaque_types = - Pure.TypeDeclId.Map.exists - (fun _ (d : Pure.type_decl) -> - match d.kind with Opaque -> true | _ -> false) - ctx.trans_types - in - let has_opaque_funs = - A.FunDeclId.Map.exists - (fun _ ((_, (t_fwd, _)) : bool * pure_fun_translation) -> - Option.is_none t_fwd.body) - ctx.trans_funs - in - (has_opaque_types, has_opaque_funs) - -(** A generic utility to generate the extracted definitions: as we may want to - split the definitions between different files (or not), we can control - what is precisely extracted. - *) -let extract_definitions (fmt : Format.formatter) (config : gen_config) - (ctx : gen_ctx) : unit = - (* Export the definition groups to the file, in the proper order *) - let export_type (qualif : ExtractToFStar.type_decl_qualif) - (id : Pure.TypeDeclId.id) : unit = - (* Retrive the declaration *) - let def = Pure.TypeDeclId.Map.find id ctx.trans_types in - (* Update the qualifier, if the type is opaque *) - let is_opaque, qualif = - match def.kind with - | Enum _ | Struct _ -> (false, qualif) - | Opaque -> - let qualif = - if config.interface then ExtractToFStar.TypeVal - else ExtractToFStar.AssumeType - in - (true, qualif) - in - (* Extract, if the config instructs to do so (depending on whether the type - * is opaque or not) *) - if - (is_opaque && config.extract_opaque) - || ((not is_opaque) && config.extract_transparent) - then ExtractToFStar.extract_type_decl ctx.extract_ctx fmt qualif def - in - - (* Utility to check a function has a decrease clause *) - let has_decreases_clause (def : Pure.fun_decl) : bool = - A.FunDeclId.Set.mem def.def_id ctx.functions_with_decreases_clause - in - - (* In case of (non-mutually) recursive functions, we use a simple procedure to - * check if the forward and backward functions are mutually recursive. - *) - let export_functions (is_rec : bool) - (pure_ls : (bool * pure_fun_translation) list) : unit = - (* Concatenate the function definitions, filtering the useless forward - * functions. We also make pairs: (forward function, backward function) - * (the forward function contains useful information that we want to keep) *) - let fls = - List.concat - (List.map - (fun (keep_fwd, (fwd, back_ls)) -> - let back_ls = List.map (fun back -> (fwd, back)) back_ls in - if keep_fwd then (fwd, fwd) :: back_ls else back_ls) - pure_ls) - in - (* Extract the decrease clauses template bodies *) - if config.extract_template_decreases_clauses then - List.iter - (fun (_, (fwd, _)) -> - let has_decr_clause = has_decreases_clause fwd in - if has_decr_clause then - ExtractToFStar.extract_template_decreases_clause ctx.extract_ctx fmt - fwd) - pure_ls; - (* Extract the function definitions *) - (if config.extract_fun_decls then - (* Check if the functions are mutually recursive - this really works - * to check if the forward and backward translations of a single - * recursive function are mutually recursive *) - let is_mut_rec = - if is_rec then - if List.length pure_ls <= 1 then - not (PureUtils.functions_not_mutually_recursive (List.map fst fls)) - else true - else false - in - List.iteri - (fun i (fwd_def, def) -> - let is_opaque = Option.is_none fwd_def.Pure.body in - let qualif = - if is_opaque then - if config.interface then ExtractToFStar.Val - else ExtractToFStar.AssumeVal - else if not is_rec then ExtractToFStar.Let - else if is_mut_rec then - if i = 0 then ExtractToFStar.LetRec else ExtractToFStar.And - else ExtractToFStar.LetRec - in - let has_decr_clause = - has_decreases_clause def && config.extract_decreases_clauses - in - (* Check if the definition needs to be filtered or not *) - if - ((not is_opaque) && config.extract_transparent) - || (is_opaque && config.extract_opaque) - then - ExtractToFStar.extract_fun_decl ctx.extract_ctx fmt qualif - has_decr_clause def) - fls); - (* Insert unit tests if necessary *) - if config.test_unit_functions then - List.iter - (fun (keep_fwd, (fwd, _)) -> - if keep_fwd then - ExtractToFStar.extract_unit_test_if_unit_fun ctx.extract_ctx fmt fwd) - pure_ls - in - - (* TODO: Check correct behaviour with opaque globals *) - let export_global (id : A.GlobalDeclId.id) : unit = - let global_decls = ctx.extract_ctx.trans_ctx.global_context.global_decls in - let global = A.GlobalDeclId.Map.find id global_decls in - let _, (body, body_backs) = - A.FunDeclId.Map.find global.body_id ctx.trans_funs - in - assert (List.length body_backs = 0); - - let is_opaque = Option.is_none body.Pure.body in - if - ((not is_opaque) && config.extract_transparent) - || (is_opaque && config.extract_opaque) - then - ExtractToFStar.extract_global_decl ctx.extract_ctx fmt global body - config.interface - in - - let export_state_type () : unit = - let qualif = - if config.interface then ExtractToFStar.TypeVal - else ExtractToFStar.AssumeType - in - ExtractToFStar.extract_state_type fmt ctx.extract_ctx qualif - in - - let export_decl (decl : Crates.declaration_group) : unit = - match decl with - | Type (NonRec id) -> - if config.extract_types then export_type ExtractToFStar.Type id - | Type (Rec ids) -> - (* Rk.: we shouldn't have (mutually) recursive opaque types *) - if config.extract_types then - List.iteri - (fun i id -> - let qualif = - if i = 0 then ExtractToFStar.Type else ExtractToFStar.And - in - export_type qualif id) - ids - | Fun (NonRec id) -> - (* Lookup *) - let pure_fun = A.FunDeclId.Map.find id ctx.trans_funs in - (* Translate *) - export_functions false [ pure_fun ] - | Fun (Rec ids) -> - (* General case of mutually recursive functions *) - (* Lookup *) - let pure_funs = - List.map (fun id -> A.FunDeclId.Map.find id ctx.trans_funs) ids - in - (* Translate *) - export_functions true pure_funs - | Global id -> export_global id - in - - (* If we need to export the state type: we try to export it after we defined - * the type definitions, because if the user wants to define a model for the - * type, he might want to reuse them in the state type. - * More specifically: if we extract functions, we have no choice but to define - * the state type before the functions, because they may reuse this state - * type: in this case, we define/declare it at the very beginning. Otherwise, - * we define/declare it at the very end. - *) - if config.extract_state_type && config.extract_fun_decls then - export_state_type (); - List.iter export_decl ctx.crate.declarations; - if config.extract_state_type && not config.extract_fun_decls then - export_state_type () - -let extract_file (config : gen_config) (ctx : gen_ctx) (filename : string) - (rust_module_name : string) (module_name : string) (custom_msg : string) - (custom_imports : string list) (custom_includes : string list) : unit = - (* Open the file and create the formatter *) - let out = open_out filename in - let fmt = Format.formatter_of_out_channel out in - - (* Print the headers. - * Note that we don't use the OCaml formatter for purpose: we want to control - * line insertion (we have to make sure that some instructions like [open MODULE] - * are printed on one line!). - * This is ok as long as we end up with a line break, so that the formatter's - * internal count is consistent with the state of the file. - *) - (* Create the header *) - Printf.fprintf out "(** THIS FILE WAS AUTOMATICALLY GENERATED BY AENEAS *)\n"; - Printf.fprintf out "(** [%s]%s *)\n" rust_module_name custom_msg; - Printf.fprintf out "module %s\n" module_name; - Printf.fprintf out "open Primitives\n"; - (* Add the custom imports *) - List.iter (fun m -> Printf.fprintf out "open %s\n" m) custom_imports; - (* Add the custom includes *) - List.iter (fun m -> Printf.fprintf out "include %s\n" m) custom_includes; - (* Z3 options - note that we use fuel 1 because it its useful for the decrease clauses *) - Printf.fprintf out "\n#set-options \"--z3rlimit 50 --fuel 1 --ifuel 1\"\n"; - - (* From now onwards, we use the formatter *) - (* Set the margin *) - Format.pp_set_margin fmt 80; - - (* Create a vertical box *) - Format.pp_open_vbox fmt 0; - - (* Extract the definitions *) - extract_definitions fmt config ctx; - - (* Close the box and end the formatting *) - Format.pp_close_box fmt (); - Format.pp_print_newline fmt (); - - (* Some logging *) - log#linfo (lazy ("Generated: " ^ filename)); - - (* Flush and close the file *) - close_out out - -(** Translate a module and write the synthesized code to an output file. - TODO: rename to translate_crate - *) -let translate_module (filename : string) (dest_dir : string) (config : config) - (crate : Crates.llbc_crate) : unit = - (* Translate the module to the pure AST *) - let trans_ctx, trans_types, trans_funs = - translate_module_to_pure config.eval_config config.mp_config - config.use_state crate - in - - (* Initialize the extraction context - for now we extract only to F* *) - let names_map = - PureToExtract.initialize_names_map ExtractToFStar.fstar_names_map_init - in - let variant_concatenate_type_name = true in - let fstar_fmt = - ExtractToFStar.mk_formatter trans_ctx crate.name - variant_concatenate_type_name - in - let ctx = - { PureToExtract.trans_ctx; names_map; fmt = fstar_fmt; indent_incr = 2 } - in - - (* We need to compute which functions are recursive, in order to know - * whether we should generate a decrease clause or not. *) - let rec_functions = - A.FunDeclId.Set.of_list - (List.concat - (List.map - (fun decl -> - match decl with Crates.Fun (Rec ids) -> ids | _ -> []) - crate.declarations)) - in - - (* Register unique names for all the top-level types, globals and functions. - * Note that the order in which we generate the names doesn't matter: - * we just need to generate a mapping from identifier to name, and make - * sure there are no name clashes. *) - let ctx = - List.fold_left - (fun ctx def -> ExtractToFStar.extract_type_decl_register_names ctx def) - ctx trans_types - in - - let ctx = - List.fold_left - (fun ctx (keep_fwd, def) -> - (* We generate a decrease clause for all the recursive functions *) - let gen_decr_clause = - A.FunDeclId.Set.mem (fst def).Pure.def_id rec_functions - in - (* Register the names, only if the function is not a global body - - * those are handled later *) - let is_global = (fst def).Pure.is_global_decl_body in - if is_global then ctx - else - ExtractToFStar.extract_fun_decl_register_names ctx keep_fwd - gen_decr_clause def) - ctx trans_funs - in - - let ctx = - List.fold_left ExtractToFStar.extract_global_decl_register_names ctx - crate.globals - in - - (* Open the output file *) - (* First compute the filename by replacing the extension and converting the - * case (rust module names are snake case) *) - let module_name, extract_filebasename = - match Filename.chop_suffix_opt ~suffix:".llbc" filename with - | None -> - (* Note that we already checked the suffix upon opening the file *) - failwith "Unreachable" - | Some filename -> - (* Retrieve the file basename *) - let basename = Filename.basename filename in - (* Convert the case *) - let module_name = StringUtils.to_camel_case basename in - (* Concatenate *) - (module_name, Filename.concat dest_dir module_name) - in - - (* Put the translated definitions in maps *) - let trans_types = - Pure.TypeDeclId.Map.of_list - (List.map (fun (d : Pure.type_decl) -> (d.def_id, d)) trans_types) - in - let trans_funs = - A.FunDeclId.Map.of_list - (List.map - (fun ((keep_fwd, (fd, bdl)) : bool * pure_fun_translation) -> - (fd.def_id, (keep_fwd, (fd, bdl)))) - trans_funs) - in - - (* Create the directory, if necessary *) - if not (Sys.file_exists dest_dir) then ( - log#linfo (lazy ("Creating missing directory: " ^ dest_dir)); - (* Create a directory with *default* permissions *) - Core_unix.mkdir_p dest_dir); - - (* Copy "Primitives.fst" - I couldn't find a "cp" function in the OCaml - * libraries... *) - let _ = - let src = open_in "fstar/Primitives.fst" in - let tgt_filename = Filename.concat dest_dir "Primitives.fst" in - let tgt = open_out tgt_filename in - try - while true do - (* We copy line by line *) - let line = input_line src in - Printf.fprintf tgt "%s\n" line - done - with End_of_file -> - close_in src; - close_out tgt; - log#linfo (lazy ("Copied: " ^ tgt_filename)) - in - - (* Extract the file(s) *) - let gen_ctx = - { - crate; - extract_ctx = ctx; - trans_types; - trans_funs; - functions_with_decreases_clause = rec_functions; - } - in - - let use_state = config.use_state in - - (* Extract one or several files, depending on the configuration *) - if config.split_files then ( - let base_gen_config = - { - mp_config = config.mp_config; - use_state; - extract_types = false; - extract_decreases_clauses = config.extract_decreases_clauses; - extract_template_decreases_clauses = false; - extract_fun_decls = false; - extract_transparent = true; - extract_opaque = false; - extract_state_type = false; - interface = false; - test_unit_functions = false; - } - in - - (* Check if there are opaque types and functions - in which case we need - * to split *) - let has_opaque_types, has_opaque_funs = module_has_opaque_decls gen_ctx in - let has_opaque_types = has_opaque_types || use_state in - - (* Extract the types *) - (* If there are opaque types, we extract in an interface *) - let types_filename_ext = if has_opaque_types then ".fsti" else ".fst" in - let types_filename = extract_filebasename ^ ".Types" ^ types_filename_ext in - let types_module = module_name ^ ".Types" in - let types_config = - { - base_gen_config with - extract_types = true; - extract_opaque = true; - extract_state_type = use_state; - interface = has_opaque_types; - } - in - extract_file types_config gen_ctx types_filename crate.Crates.name - types_module ": type definitions" [] []; - - (* Extract the template clauses *) - let needs_clauses_module = - config.extract_decreases_clauses - && not (A.FunDeclId.Set.is_empty rec_functions) - in - (if needs_clauses_module && config.extract_template_decreases_clauses then - let clauses_filename = extract_filebasename ^ ".Clauses.Template.fst" in - let clauses_module = module_name ^ ".Clauses.Template" in - let clauses_config = - { base_gen_config with extract_template_decreases_clauses = true } - in - extract_file clauses_config gen_ctx clauses_filename crate.Crates.name - clauses_module ": templates for the decreases clauses" [ types_module ] - []); - - (* Extract the opaque functions, if needed *) - let opaque_funs_module = - if has_opaque_funs then ( - let opaque_filename = extract_filebasename ^ ".Opaque.fsti" in - let opaque_module = module_name ^ ".Opaque" in - let opaque_config = - { - base_gen_config with - extract_fun_decls = true; - extract_transparent = false; - extract_opaque = true; - interface = true; - } - in - extract_file opaque_config gen_ctx opaque_filename crate.Crates.name - opaque_module ": opaque function definitions" [] [ types_module ]; - [ opaque_module ]) - else [] - in - - (* Extract the functions *) - let fun_filename = extract_filebasename ^ ".Funs.fst" in - let fun_module = module_name ^ ".Funs" in - let fun_config = - { - base_gen_config with - extract_fun_decls = true; - test_unit_functions = config.test_unit_functions; - } - in - let clauses_module = - if needs_clauses_module then [ module_name ^ ".Clauses" ] else [] - in - extract_file fun_config gen_ctx fun_filename crate.Crates.name fun_module - ": function definitions" [] - ([ types_module ] @ opaque_funs_module @ clauses_module)) - else - let gen_config = - { - mp_config = config.mp_config; - use_state; - extract_types = true; - extract_decreases_clauses = config.extract_decreases_clauses; - extract_template_decreases_clauses = - config.extract_template_decreases_clauses; - extract_fun_decls = true; - extract_transparent = true; - extract_opaque = true; - extract_state_type = use_state; - interface = false; - test_unit_functions = config.test_unit_functions; - } - in - (* Add the extension for F* *) - let extract_filename = extract_filebasename ^ ".fst" in - extract_file gen_config gen_ctx extract_filename crate.Crates.name - module_name "" [] [] diff --git a/src/TranslateCore.ml b/src/TranslateCore.ml deleted file mode 100644 index a658147d..00000000 --- a/src/TranslateCore.ml +++ /dev/null @@ -1,65 +0,0 @@ -(** Some utilities for the translation *) - -open InterpreterStatements -module L = Logging -module T = Types -module A = LlbcAst -module SA = SymbolicAst -module FA = FunsAnalysis - -(** The local logger *) -let log = L.translate_log - -type type_context = C.type_context [@@deriving show] - -type fun_context = { - fun_decls : A.fun_decl A.FunDeclId.Map.t; - fun_infos : FA.fun_info A.FunDeclId.Map.t; -} -[@@deriving show] - -type global_context = C.global_context [@@deriving show] - -type trans_ctx = { - type_context : type_context; - fun_context : fun_context; - global_context : global_context; -} - -type pure_fun_translation = Pure.fun_decl * Pure.fun_decl list - -let type_decl_to_string (ctx : trans_ctx) (def : Pure.type_decl) : string = - let type_params = def.type_params in - let type_decls = ctx.type_context.type_decls in - let fmt = PrintPure.mk_type_formatter type_decls type_params in - PrintPure.type_decl_to_string fmt def - -let type_id_to_string (ctx : trans_ctx) (def : Pure.type_decl) : string = - let type_params = def.type_params in - let type_decls = ctx.type_context.type_decls in - let fmt = PrintPure.mk_type_formatter type_decls type_params in - PrintPure.type_decl_to_string fmt def - -let fun_sig_to_string (ctx : trans_ctx) (sg : Pure.fun_sig) : string = - let type_params = sg.type_params in - let type_decls = ctx.type_context.type_decls in - let fun_decls = ctx.fun_context.fun_decls in - let global_decls = ctx.global_context.global_decls in - let fmt = - PrintPure.mk_ast_formatter type_decls fun_decls global_decls type_params - in - PrintPure.fun_sig_to_string fmt sg - -let fun_decl_to_string (ctx : trans_ctx) (def : Pure.fun_decl) : string = - let type_params = def.signature.type_params in - let type_decls = ctx.type_context.type_decls in - let fun_decls = ctx.fun_context.fun_decls in - let global_decls = ctx.global_context.global_decls in - let fmt = - PrintPure.mk_ast_formatter type_decls fun_decls global_decls type_params - in - PrintPure.fun_decl_to_string fmt def - -let fun_decl_id_to_string (ctx : trans_ctx) (id : A.FunDeclId.id) : string = - Print.fun_name_to_string - (A.FunDeclId.Map.find id ctx.fun_context.fun_decls).name diff --git a/src/Types.ml b/src/Types.ml deleted file mode 100644 index 326ef76f..00000000 --- a/src/Types.ml +++ /dev/null @@ -1,208 +0,0 @@ -open Identifiers -open Names -open Meta -module TypeVarId = IdGen () -module TypeDeclId = IdGen () -module VariantId = IdGen () -module FieldId = IdGen () - -(** Region variable ids. Used in function signatures. *) -module RegionVarId = IdGen () - -(** Region ids. Used for symbolic executions. *) -module RegionId = IdGen () - -module RegionGroupId = IdGen () - -type ('id, 'name) indexed_var = { - index : 'id; (** Unique index identifying the variable *) - name : 'name; (** Variable name *) -} -[@@deriving show] - -type type_var = (TypeVarId.id, string) indexed_var [@@deriving show] -type region_var = (RegionVarId.id, string option) indexed_var [@@deriving show] - -(** A region. - - Regions are used in function signatures (in which case we use region variable - ids) and in symbolic variables and projections (in which case we use region - ids). - *) -type 'rid region = - | Static (** Static region *) - | Var of 'rid (** Non-static region *) -[@@deriving show, ord] - -(** The type of erased regions. - - We could use unit, but having a dedicated type makes things more explicit. - *) -type erased_region = Erased [@@deriving show, ord] - -(** A group of regions. - - Results from a lifetime analysis: we group the regions with the same - lifetime together, and compute the hierarchy between the regions. - This is necessary to introduce the proper abstraction with the - proper constraints, when evaluating a function call in symbolic mode. -*) -type ('id, 'r) g_region_group = { - id : 'id; - regions : 'r list; - parents : 'id list; -} -[@@deriving show] - -type ('r, 'id) g_region_groups = ('r, 'id) g_region_group list [@@deriving show] - -type region_var_group = (RegionGroupId.id, RegionVarId.id) g_region_group -[@@deriving show] - -type region_var_groups = (RegionGroupId.id, RegionVarId.id) g_region_groups -[@@deriving show] - -type integer_type = - | Isize - | I8 - | I16 - | I32 - | I64 - | I128 - | Usize - | U8 - | U16 - | U32 - | U64 - | U128 -[@@deriving show, ord] - -let all_signed_int_types = [ Isize; I8; I16; I32; I64; I128 ] -let all_unsigned_int_types = [ Usize; U8; U16; U32; U64; U128 ] -let all_int_types = List.append all_signed_int_types all_unsigned_int_types - -type ref_kind = Mut | Shared [@@deriving show, ord] -type assumed_ty = Box | Vec | Option [@@deriving show, ord] - -(** The variant id for [Option::None] *) -let option_none_id = VariantId.of_int 0 - -(** The variant id for [Option::Some] *) -let option_some_id = VariantId.of_int 1 - -(** Type identifier for ADTs. - - ADTs are very general in our encoding: they account for "regular" ADTs, - tuples and also assumed types. -*) -type type_id = AdtId of TypeDeclId.id | Tuple | Assumed of assumed_ty -[@@deriving show, ord] - -(** Ancestor for iter visitor for [ty] *) -class ['self] iter_ty_base = - object (_self : 'self) - inherit [_] VisitorsRuntime.iter - method visit_'r : 'env -> 'r -> unit = fun _ _ -> () - method visit_id : 'env -> TypeVarId.id -> unit = fun _ _ -> () - method visit_type_id : 'env -> type_id -> unit = fun _ _ -> () - method visit_integer_type : 'env -> integer_type -> unit = fun _ _ -> () - method visit_ref_kind : 'env -> ref_kind -> unit = fun _ _ -> () - end - -(** Ancestor for map visitor for [ty] *) -class ['self] map_ty_base = - object (_self : 'self) - inherit [_] VisitorsRuntime.map - method visit_'r : 'env -> 'r -> 'r = fun _ r -> r - method visit_id : 'env -> TypeVarId.id -> TypeVarId.id = fun _ id -> id - method visit_type_id : 'env -> type_id -> type_id = fun _ id -> id - - method visit_integer_type : 'env -> integer_type -> integer_type = - fun _ ity -> ity - - method visit_ref_kind : 'env -> ref_kind -> ref_kind = fun _ rk -> rk - end - -type 'r ty = - | Adt of type_id * 'r list * 'r ty list - (** {!Adt} encodes ADTs, tuples and assumed types *) - | TypeVar of TypeVarId.id - | Bool - | Char - | Never - | Integer of integer_type - | Str - | Array of 'r ty (* TODO: there should be a constant with the array *) - | Slice of 'r ty - | Ref of 'r * 'r ty * ref_kind -[@@deriving - show, - ord, - visitors - { - name = "iter_ty"; - variety = "iter"; - ancestors = [ "iter_ty_base" ]; - nude = true (* Don't inherit {!VisitorsRuntime.iter} *); - concrete = true; - polymorphic = false; - }, - visitors - { - name = "map_ty"; - variety = "map"; - ancestors = [ "map_ty_base" ]; - nude = true (* Don't inherit {!VisitorsRuntime.iter} *); - concrete = true; - polymorphic = false; - }] -(* TODO: group Bool, Char, etc. in Constant *) - -(** Generic type with regions *) -type 'r gr_ty = 'r region ty [@@deriving show, ord] - -(** *S*ignature types. - - Used in function signatures and type definitions. - *) -type sty = RegionVarId.id gr_ty [@@deriving show, ord] - -(** Type with *R*egions. - - Used to project borrows/loans inside of abstractions, during symbolic - execution. - *) -type rty = RegionId.id gr_ty [@@deriving show, ord] - -(** Type with *E*rased regions. - - Used in function bodies, "regular" value types, etc. - *) -type ety = erased_region ty [@@deriving show, ord] - -type field = { meta : meta; field_name : string option; field_ty : sty } -[@@deriving show] - -type variant = { meta : meta; variant_name : string; fields : field list } -[@@deriving show] - -type type_decl_kind = - | Struct of field list - | Enum of variant list - | Opaque - (** An opaque type: either a local type marked as opaque, or an external type *) -[@@deriving show] - -type type_decl = { - def_id : TypeDeclId.id; - meta : meta; - name : type_name; - region_params : region_var list; - type_params : type_var list; - kind : type_decl_kind; - regions_hierarchy : region_var_groups; - (** Stores the hierarchy between the regions (which regions have the - same lifetime, which lifetime should end before which other lifetime, - etc.) *) -} -[@@deriving show] diff --git a/src/TypesAnalysis.ml b/src/TypesAnalysis.ml deleted file mode 100644 index 60ce5149..00000000 --- a/src/TypesAnalysis.ml +++ /dev/null @@ -1,328 +0,0 @@ -open Types -open Crates - -type subtype_info = { - under_borrow : bool; (** Are we inside a borrow? *) - under_mut_borrow : bool; (** Are we inside a mut borrow? *) -} -[@@deriving show] - -(** See {!type_decl_info} *) -type type_param_info = subtype_info [@@deriving show] - -type expl_info = subtype_info [@@deriving show] - -type type_borrows_info = { - contains_static : bool; - (** Does the type (transitively) contains a static borrow? *) - contains_borrow : bool; - (** Does the type (transitively) contains a borrow? *) - contains_nested_borrows : bool; - (** Does the type (transitively) contains nested borrows? *) - contains_borrow_under_mut : bool; -} -[@@deriving show] - -(** Generic definition *) -type 'p g_type_info = { - borrows_info : type_borrows_info; - (** Various informations about the borrows *) - param_infos : 'p; (** Gives information about the type parameters *) -} -[@@deriving show] - -(** Information about a type definition. *) -type type_decl_info = type_param_info list g_type_info [@@deriving show] - -(** Information about a type. *) -type ty_info = type_borrows_info [@@deriving show] - -(** Helper definition. - - Allows us to factorize code: {!analyze_full_ty} is used both to analyze - type definitions and types. *) -type partial_type_info = type_param_info list option g_type_info -[@@deriving show] - -type type_infos = type_decl_info TypeDeclId.Map.t [@@deriving show] - -let expl_info_init = { under_borrow = false; under_mut_borrow = false } - -let type_borrows_info_init : type_borrows_info = - { - contains_static = false; - contains_borrow = false; - contains_nested_borrows = false; - contains_borrow_under_mut = false; - } - -let initialize_g_type_info (param_infos : 'p) : 'p g_type_info = - { borrows_info = type_borrows_info_init; param_infos } - -let initialize_type_decl_info (def : type_decl) : type_decl_info = - let param_info = { under_borrow = false; under_mut_borrow = false } in - let param_infos = List.map (fun _ -> param_info) def.type_params in - initialize_g_type_info param_infos - -let type_decl_info_to_partial_type_info (info : type_decl_info) : - partial_type_info = - { borrows_info = info.borrows_info; param_infos = Some info.param_infos } - -let partial_type_info_to_type_decl_info (info : partial_type_info) : - type_decl_info = - { - borrows_info = info.borrows_info; - param_infos = Option.get info.param_infos; - } - -let partial_type_info_to_ty_info (info : partial_type_info) : ty_info = - info.borrows_info - -let analyze_full_ty (r_is_static : 'r -> bool) (updated : bool ref) - (infos : type_infos) (ty_info : partial_type_info) (ty : 'r ty) : - partial_type_info = - (* Small utility *) - let check_update_bool (original : bool) (nv : bool) : bool = - if nv && not original then ( - updated := true; - nv) - else original - in - - (* Update a partial_type_info, while registering if we actually performed an update *) - let update_ty_info (ty_info : partial_type_info) - (ty_b_info : type_borrows_info) : partial_type_info = - let original = ty_info.borrows_info in - let contains_static = - check_update_bool original.contains_static ty_b_info.contains_static - in - let contains_borrow = - check_update_bool original.contains_borrow ty_b_info.contains_borrow - in - let contains_nested_borrows = - check_update_bool original.contains_nested_borrows - ty_b_info.contains_nested_borrows - in - let contains_borrow_under_mut = - check_update_bool original.contains_borrow_under_mut - ty_b_info.contains_borrow_under_mut - in - let updated_borrows_info = - { - contains_static; - contains_borrow; - contains_nested_borrows; - contains_borrow_under_mut; - } - in - { ty_info with borrows_info = updated_borrows_info } - in - - (* The recursive function which explores the type *) - let rec analyze (expl_info : expl_info) (ty_info : partial_type_info) - (ty : 'r ty) : partial_type_info = - match ty with - | Bool | Char | Never | Integer _ | Str -> ty_info - | TypeVar var_id -> ( - (* Update the information for the proper parameter, if necessary *) - match ty_info.param_infos with - | None -> ty_info - | Some param_infos -> - let param_info = TypeVarId.nth param_infos var_id in - (* Set [under_borrow] *) - let under_borrow = - check_update_bool param_info.under_borrow expl_info.under_borrow - in - (* Set [under_nested_borrows] *) - let under_mut_borrow = - check_update_bool param_info.under_mut_borrow - expl_info.under_mut_borrow - in - (* Update param_info *) - let param_info = { under_borrow; under_mut_borrow } in - let param_infos = - TypeVarId.update_nth param_infos var_id param_info - in - let param_infos = Some param_infos in - { ty_info with param_infos }) - | Array ty | Slice ty -> - (* Just dive in *) - analyze expl_info ty_info ty - | Ref (r, rty, rkind) -> - (* Update the type info *) - let contains_static = r_is_static r in - let contains_borrow = true in - let contains_nested_borrows = expl_info.under_borrow in - let contains_borrow_under_mut = expl_info.under_mut_borrow in - let ty_b_info = - { - contains_static; - contains_borrow; - contains_nested_borrows; - contains_borrow_under_mut; - } - in - let ty_info = update_ty_info ty_info ty_b_info in - (* Update the exploration info *) - let expl_info = - { - under_borrow = true; - under_mut_borrow = expl_info.under_mut_borrow || rkind = Mut; - } - in - (* Continue exploring *) - analyze expl_info ty_info rty - | Adt ((Tuple | Assumed (Box | Vec | Option)), _, tys) -> - (* Nothing to update: just explore the type parameters *) - List.fold_left - (fun ty_info ty -> analyze expl_info ty_info ty) - ty_info tys - | Adt (AdtId adt_id, regions, tys) -> - (* Lookup the information for this type definition *) - let adt_info = TypeDeclId.Map.find adt_id infos in - (* Update the type info with the information from the adt *) - let ty_info = update_ty_info ty_info adt_info.borrows_info in - (* Check if 'static appears in the region parameters *) - let found_static = List.exists r_is_static regions in - let borrows_info = ty_info.borrows_info in - let borrows_info = - { - borrows_info with - contains_static = - check_update_bool borrows_info.contains_static found_static; - } - in - let ty_info = { ty_info with borrows_info } in - (* For every instantiated type parameter: update the exploration info - * then explore the type *) - let params_tys = List.combine adt_info.param_infos tys in - let ty_info = - List.fold_left - (fun ty_info (param_info, ty) -> - (* Update the type info *) - (* Below: we use only the information which we learn only - * by taking the type parameter into account. *) - let contains_static = false in - let contains_borrow = param_info.under_borrow in - let contains_nested_borrows = - expl_info.under_borrow && param_info.under_borrow - in - let contains_borrow_under_mut = - expl_info.under_mut_borrow && param_info.under_borrow - in - let ty_b_info = - { - contains_static; - contains_borrow; - contains_nested_borrows; - contains_borrow_under_mut; - } - in - let ty_info = update_ty_info ty_info ty_b_info in - (* Update the exploration info *) - let expl_info = - { - under_borrow = - expl_info.under_borrow || param_info.under_borrow; - under_mut_borrow = - expl_info.under_mut_borrow || param_info.under_mut_borrow; - } - in - (* Continue exploring *) - analyze expl_info ty_info ty) - ty_info params_tys - in - (* Return *) - ty_info - in - (* Explore *) - analyze expl_info_init ty_info ty - -let type_decl_is_opaque (d : type_decl) : bool = - match d.kind with Struct _ | Enum _ -> false | Opaque -> true - -let analyze_type_decl (updated : bool ref) (infos : type_infos) - (def : type_decl) : type_infos = - (* We analyze the type declaration only if it is not opaque (we need to explore - * the variants of the ADTs *) - if type_decl_is_opaque def then infos - else - (* Retrieve all the types of all the fields of all the variants *) - let fields_tys : sty list = - match def.kind with - | Struct fields -> List.map (fun f -> f.field_ty) fields - | Enum variants -> - List.concat - (List.map - (fun v -> List.map (fun f -> f.field_ty) v.fields) - variants) - | Opaque -> raise (Failure "unreachable") - in - (* Explore the types and accumulate information *) - let r_is_static r = r = Static in - let type_decl_info = TypeDeclId.Map.find def.def_id infos in - let type_decl_info = type_decl_info_to_partial_type_info type_decl_info in - let type_decl_info = - List.fold_left - (fun type_decl_info ty -> - analyze_full_ty r_is_static updated infos type_decl_info ty) - type_decl_info fields_tys - in - let type_decl_info = partial_type_info_to_type_decl_info type_decl_info in - (* Update the information for the type definition we explored *) - let infos = TypeDeclId.Map.add def.def_id type_decl_info infos in - (* Return *) - infos - -let analyze_type_declaration_group (type_decls : type_decl TypeDeclId.Map.t) - (infos : type_infos) (decl : type_declaration_group) : type_infos = - (* Collect the identifiers used in the declaration group *) - let ids = match decl with NonRec id -> [ id ] | Rec ids -> ids in - (* Retrieve the type definitions *) - let decl_defs = List.map (fun id -> TypeDeclId.Map.find id type_decls) ids in - (* Initialize the type information for the current definitions *) - let infos = - List.fold_left - (fun infos def -> - TypeDeclId.Map.add def.def_id (initialize_type_decl_info def) infos) - infos decl_defs - in - (* Analyze the types - this function simply computes a fixed-point *) - let updated : bool ref = ref false in - let rec analyze (infos : type_infos) : type_infos = - let infos = - List.fold_left - (fun infos def -> analyze_type_decl updated infos def) - infos decl_defs - in - if !updated then ( - updated := false; - analyze infos) - else infos - in - analyze infos - -(** Compute the type information for every *type definition* in a list of - declarations. This type definition information is later used to easily - compute the information of arbitrary types. - - Rk.: pay attention to the difference between type definitions and types! - *) -let analyze_type_declarations (type_decls : type_decl TypeDeclId.Map.t) - (decls : type_declaration_group list) : type_infos = - List.fold_left - (fun infos decl -> analyze_type_declaration_group type_decls infos decl) - TypeDeclId.Map.empty decls - -(** Analyze a type to check whether it contains borrows, etc., provided - we have already analyzed the type definitions in the context. - *) -let analyze_ty (infos : type_infos) (ty : 'r ty) : ty_info = - (* We don't use [updated] but need to give it as parameter *) - let updated = ref false in - (* We don't need to compute whether the type contains 'static or not *) - let r_is_static _ = false in - let ty_info = initialize_g_type_info None in - let ty_info = analyze_full_ty r_is_static updated infos ty_info ty in - (* Convert the ty_info *) - partial_type_info_to_ty_info ty_info diff --git a/src/TypesUtils.ml b/src/TypesUtils.ml deleted file mode 100644 index 7531dd8b..00000000 --- a/src/TypesUtils.ml +++ /dev/null @@ -1,190 +0,0 @@ -open Types -open Utils -module TA = TypesAnalysis - -let type_decl_is_opaque (d : type_decl) : bool = - match d.kind with Struct _ | Enum _ -> false | Opaque -> true - -(** Retrieve the list of fields for the given variant of a {!Types.type_decl}. - - Raises [Invalid_argument] if the arguments are incorrect. - *) -let type_decl_get_fields (def : type_decl) - (opt_variant_id : VariantId.id option) : field list = - match (def.kind, opt_variant_id) with - | Enum variants, Some variant_id -> (VariantId.nth variants variant_id).fields - | Struct fields, None -> fields - | _ -> - let opt_variant_id = - match opt_variant_id with None -> "None" | Some _ -> "Some" - in - raise - (Invalid_argument - ("The variant id should be [Some] if and only if the definition is \ - an enumeration:\n\ - - def: " ^ show_type_decl def ^ "\n- opt_variant_id: " - ^ opt_variant_id)) - -(** Return [true] if a {!Types.ty} is actually [unit] *) -let ty_is_unit (ty : 'r ty) : bool = - match ty with Adt (Tuple, [], []) -> true | _ -> false - -let ty_is_adt (ty : 'r ty) : bool = - match ty with Adt (_, _, _) -> true | _ -> false - -let ty_as_adt (ty : 'r ty) : type_id * 'r list * 'r ty list = - match ty with - | Adt (id, regions, tys) -> (id, regions, tys) - | _ -> failwith "Unreachable" - -let ty_is_custom_adt (ty : 'r ty) : bool = - match ty with Adt (AdtId _, _, _) -> true | _ -> false - -let ty_as_custom_adt (ty : 'r ty) : TypeDeclId.id * 'r list * 'r ty list = - match ty with - | Adt (AdtId id, regions, tys) -> (id, regions, tys) - | _ -> failwith "Unreachable" - -(** The unit type *) -let mk_unit_ty : 'r ty = Adt (Tuple, [], []) - -(** The usize type *) -let mk_usize_ty : 'r ty = Integer Usize - -(** Deconstruct a type of the form [Box<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/src/Utils.ml b/src/Utils.ml deleted file mode 100644 index a285e869..00000000 --- a/src/Utils.ml +++ /dev/null @@ -1,6 +0,0 @@ -exception Found -(** Utility exception - - When looking for something while exploring a term, it can be easier to - just throw an exception to signal we found what we were looking for. - *) diff --git a/src/Values.ml b/src/Values.ml deleted file mode 100644 index e404f40d..00000000 --- a/src/Values.ml +++ /dev/null @@ -1,844 +0,0 @@ -open Identifiers -open Types - -(* TODO: I often write "abstract" (value, borrow content, etc.) while I should - * write "abstraction" (because those values are not abstract, they simply are - * inside abstractions) *) - -module VarId = IdGen () -module BorrowId = IdGen () -module SymbolicValueId = IdGen () -module AbstractionId = IdGen () -module FunCallId = IdGen () - -(** A variable *) - -type big_int = Z.t - -let big_int_of_yojson (json : Yojson.Safe.t) : (big_int, string) result = - match json with - | `Int i -> Ok (Z.of_int i) - | `Intlit is -> Ok (Z.of_string is) - | _ -> Error "not an integer or an integer literal" - -let big_int_to_yojson (i : big_int) = `Intlit (Z.to_string i) - -let pp_big_int (fmt : Format.formatter) (bi : big_int) : unit = - Format.pp_print_string fmt (Z.to_string bi) - -let show_big_int (bi : big_int) : string = Z.to_string bi - -(** A scalar value - - Note that we use unbounded integers everywhere. - We then harcode the boundaries for the different types. - *) -type scalar_value = { value : big_int; int_ty : integer_type } [@@deriving show] - -(** A constant value *) -type constant_value = - | Scalar of scalar_value - | Bool of bool - | Char of char - | String of string -[@@deriving show] - -(** The kind of a symbolic value, which precises how the value was generated *) -type sv_kind = - | FunCallRet (** The value is the return value of a function call *) - | FunCallGivenBack - (** The value is a borrowed value given back by an abstraction - (happens when giving a borrow to a function: when the abstraction - introduced to model the function call ends we reintroduce a symbolic - value in the context for the value modified by the abstraction through - the borrow). - *) - | SynthInput - (** The value is an input value of the function whose body we are - currently synthesizing. - *) - | SynthRetGivenBack - (** The value is a borrowed value that the function whose body we are - synthesizing returned, and which was given back because we ended - one of the lifetimes of this function (we do this to synthesize - the backward functions). - *) - | SynthInputGivenBack - (** The value was given back upon ending one of the input abstractions *) - | Global (** The value is a global *) -[@@deriving show] - -(** A symbolic value *) -type symbolic_value = { - sv_kind : sv_kind; - sv_id : SymbolicValueId.id; - sv_ty : rty; -} -[@@deriving show] - -(** Ancestor for {!typed_value} iter visitor *) -class ['self] iter_typed_value_base = - object (_self : 'self) - inherit [_] VisitorsRuntime.iter - method visit_constant_value : 'env -> constant_value -> unit = fun _ _ -> () - method visit_erased_region : 'env -> erased_region -> unit = fun _ _ -> () - method visit_symbolic_value : 'env -> symbolic_value -> unit = fun _ _ -> () - method visit_ety : 'env -> ety -> unit = fun _ _ -> () - end - -(** Ancestor for {!typed_value} map visitor for *) -class ['self] map_typed_value_base = - object (_self : 'self) - inherit [_] VisitorsRuntime.map - - method visit_constant_value : 'env -> constant_value -> constant_value = - fun _ cv -> cv - - method visit_erased_region : 'env -> erased_region -> erased_region = - fun _ r -> r - - method visit_symbolic_value : 'env -> symbolic_value -> symbolic_value = - fun _ sv -> sv - - method visit_ety : 'env -> ety -> ety = fun _ ty -> ty - end - -(** An untyped value, used in the environments *) -type value = - | Concrete of constant_value (** Concrete (non-symbolic) value *) - | Adt of adt_value (** Enumerations and structures *) - | Bottom (** No value (uninitialized or moved value) *) - | Borrow of borrow_content (** A borrowed value *) - | Loan of loan_content (** A loaned value *) - | Symbolic of symbolic_value - (** Borrow projector over a symbolic value. - - Note that contrary to the abstraction-values case, symbolic values - appearing in regular values are interpreted as *borrow* projectors, - they can never be *loan* projectors. - *) - -and adt_value = { - variant_id : (VariantId.id option[@opaque]); - field_values : typed_value list; -} - -and borrow_content = - | SharedBorrow of mvalue * (BorrowId.id[@opaque]) - (** A shared borrow. - - We remember the shared value which was borrowed as a meta value. - This is necessary for synthesis: upon translating to "pure" values, - we can't perform any lookup because we don't have an environment - anymore. Note that it is ok to keep the shared value and copy - the shared value this way, because shared values are immutable - for as long as they are shared (i.e., as long as we can use the - shared borrow). - *) - | MutBorrow of (BorrowId.id[@opaque]) * typed_value - (** A mutably borrowed value. *) - | InactivatedMutBorrow of mvalue * (BorrowId.id[@opaque]) - (** An inactivated mut borrow. - - This is used to model {{: https://rustc-dev-guide.rust-lang.org/borrow_check/two_phase_borrows.html} two-phase borrows}. - When evaluating a two-phase mutable borrow, we first introduce an inactivated - borrow which behaves like a shared borrow, until the moment we actually *use* - the borrow: at this point, we end all the other shared borrows (or inactivated - borrows - though there shouldn't be any other inactivated borrows if the program - is well typed) of this value and replace the inactivated borrow with a - mutable borrow. - - A simple use case of two-phase borrows: - {[ - let mut v = Vec::new(); - v.push(v.len()); - ]} - - This gets desugared to (something similar to) the following MIR: - {[ - v = Vec::new(); - v1 = &mut v; - v2 = &v; // We need this borrow, but v has already been mutably borrowed! - l = Vec::len(move v2); - Vec::push(move v1, move l); // In practice, v1 gets activated only here - ]} - - The meta-value is used for the same purposes as with shared borrows, - at the exception that in case of inactivated borrows it is not - *necessary* for the synthesis: we keep it only as meta-information. - To be more precise: - - when generating the synthesized program, we may need to convert - shared borrows to pure values - - we never need to do so for inactivated borrows: such borrows must - be activated at the moment we use them (meaning we convert a *mutable* - borrow to a pure value). However, we save meta-data about the assignments, - which is used to make the code cleaner: when generating this meta-data, - we may need to convert inactivated borrows to pure values, in which - situation we convert the meta-value we stored in the inactivated - borrow. - *) - -and loan_content = - | SharedLoan of (BorrowId.Set.t[@opaque]) * typed_value - | MutLoan of (BorrowId.id[@opaque]) - (** TODO: we might want to add a set of borrow ids (useful for inactivated - borrows, and extremely useful when giving shared values to abstractions). - *) - -(** "Meta"-value: information we store for the synthesis. - - Note that we never automatically visit the meta-values with the - visitors: they really are meta information, and shouldn't be considered - as part of the environment during a symbolic execution. - - TODO: we may want to create wrappers, to prevent accidently mixing meta - values and regular values. - *) -and mvalue = typed_value - -(** "Regular" typed value (we map variables to typed values) *) -and typed_value = { value : value; ty : ety } -[@@deriving - show, - visitors - { - name = "iter_typed_value_visit_mvalue"; - variety = "iter"; - ancestors = [ "iter_typed_value_base" ]; - nude = true (* Don't inherit {!VisitorsRuntime.iter} *); - concrete = true; - }, - visitors - { - name = "map_typed_value_visit_mvalue"; - variety = "map"; - ancestors = [ "map_typed_value_base" ]; - nude = true (* Don't inherit {!VisitorsRuntime.iter} *); - concrete = true; - }] - -(** We have to override the {!iter_typed_value_visit_mvalue.visit_mvalue} method, - to ignore meta-values *) -class ['self] iter_typed_value = - object (_self : 'self) - inherit [_] iter_typed_value_visit_mvalue - method! visit_mvalue : 'env -> mvalue -> unit = fun _ _ -> () - end - -(** We have to override the {!iter_typed_value_visit_mvalue.visit_mvalue} method, - to ignore meta-values *) -class ['self] map_typed_value = - object (_self : 'self) - inherit [_] map_typed_value_visit_mvalue - method! visit_mvalue : 'env -> mvalue -> mvalue = fun _ x -> x - end - -(** "Meta"-symbolic value. - - See the explanations for {!mvalue} - - TODO: we may want to create wrappers, to prevent mixing meta values - and regular values. - *) -type msymbolic_value = symbolic_value [@@deriving show] - -(** When giving shared borrows to functions (i.e., inserting shared borrows inside - abstractions) we need to reborrow the shared values. When doing so, we lookup - the shared values and apply some special projections to the shared value - (until we can't go further, i.e., we find symbolic values which may get - expanded upon reading them later), which don't generate avalues but - sets of borrow ids and symbolic values. - - Note that as shared values can't get modified it is ok to forget the - structure of the values we projected, and only keep the set of borrows - (and symbolic values). - - TODO: we may actually need to remember the structure, in order to know - which borrows are inside which other borrows... -*) -type abstract_shared_borrow = - | AsbBorrow of (BorrowId.id[@opaque]) - | AsbProjReborrows of (symbolic_value[@opaque]) * (rty[@opaque]) -[@@deriving show] - -(** A set of abstract shared borrows *) -type abstract_shared_borrows = abstract_shared_borrow list [@@deriving show] - -(** Ancestor for {!aproj} iter visitor *) -class ['self] iter_aproj_base = - object (_self : 'self) - inherit [_] iter_typed_value - method visit_rty : 'env -> rty -> unit = fun _ _ -> () - - method visit_msymbolic_value : 'env -> msymbolic_value -> unit = - fun _ _ -> () - end - -(** Ancestor for {!aproj} map visitor *) -class ['self] map_aproj_base = - object (_self : 'self) - inherit [_] map_typed_value - method visit_rty : 'env -> rty -> rty = fun _ ty -> ty - - method visit_msymbolic_value : 'env -> msymbolic_value -> msymbolic_value = - fun _ m -> m - end - -type aproj = - | AProjLoans of symbolic_value * (msymbolic_value * aproj) list - (** A projector of loans over a symbolic value. - - Note that the borrows of a symbolic value may be spread between - different abstractions, meaning that the projector of loans might - receive *several* (symbolic) given back values. - - This is the case in the following example: - {[ - fn f<'a> (...) -> (&'a mut u32, &'a mut u32); - fn g<'b, 'c>(p : (&'b mut u32, &'c mut u32)); - - let p = f(...); - g(move p); - - // Symbolic context after the call to g: - // abs'a {'a} { [s@0 <: (&'a mut u32, &'a mut u32)] } - // - // abs'b {'b} { (s@0 <: (&'b mut u32, &'c mut u32)) } - // abs'c {'c} { (s@0 <: (&'b mut u32, &'c mut u32)) } - ]} - - Upon evaluating the call to [f], we introduce a symbolic value [s@0] - and a projector of loans (projector loans from the region 'c). - This projector will later receive two given back values: one for - 'a and one for 'b. - - We accumulate those values in the list of projections (note that - the meta value stores the value which was given back). - - We can later end the projector of loans if [s@0] is not referenced - anywhere in the context below a projector of borrows which intersects - this projector of loans. - *) - | AProjBorrows of symbolic_value * rty - (** Note that an AProjBorrows only operates on a value which is not below - a shared loan: under a shared loan, we use {!abstract_shared_borrow}. - - Also note that once given to a borrow projection, a symbolic value - can't get updated/expanded: this means that we don't need to save - any meta-value here. - *) - | AEndedProjLoans of msymbolic_value * (msymbolic_value * aproj) list - (** An ended projector of loans over a symbolic value. - - See the explanations for {!AProjLoans} - - Note that we keep the original symbolic value as a meta-value. - *) - | AEndedProjBorrows of msymbolic_value - (** The only purpose of {!AEndedProjBorrows} is to store, for synthesis - purposes, the symbolic value which was generated and given back upon - ending the borrow. - *) - | AIgnoredProjBorrows -[@@deriving - show, - visitors - { - name = "iter_aproj"; - variety = "iter"; - ancestors = [ "iter_aproj_base" ]; - nude = true (* Don't inherit {!VisitorsRuntime.iter} *); - concrete = true; - }, - visitors - { - name = "map_aproj"; - variety = "map"; - ancestors = [ "map_aproj_base" ]; - nude = true (* Don't inherit {!VisitorsRuntime.iter} *); - concrete = true; - }] - -type region = RegionVarId.id Types.region [@@deriving show] - -(** Ancestor for {!typed_avalue} iter visitor *) -class ['self] iter_typed_avalue_base = - object (_self : 'self) - inherit [_] iter_aproj - method visit_id : 'env -> BorrowId.id -> unit = fun _ _ -> () - method visit_region : 'env -> region -> unit = fun _ _ -> () - - method visit_abstract_shared_borrows - : 'env -> abstract_shared_borrows -> unit = - fun _ _ -> () - end - -(** Ancestor for {!typed_avalue} map visitor *) -class ['self] map_typed_avalue_base = - object (_self : 'self) - inherit [_] map_aproj - method visit_id : 'env -> BorrowId.id -> BorrowId.id = fun _ id -> id - method visit_region : 'env -> region -> region = fun _ r -> r - - method visit_abstract_shared_borrows - : 'env -> abstract_shared_borrows -> abstract_shared_borrows = - fun _ asb -> asb - end - -(** Abstraction values are used inside of abstractions to properly model - borrowing relations introduced by function calls. - - When calling a function, we lose information about the borrow graph: - part of it is thus "abstracted" away. -*) -type avalue = - | AConcrete of constant_value - (** TODO: remove. We actually don't use that for the synthesis, but the - meta-values. - - Note that this case is not used in the projections to keep track of the - borrow graph (because there are no borrows in "concrete" values!) but - to correctly instantiate the backward functions (we may give back some - values at different moments: we need to remember what those values were - precisely). Also note that even though avalues and values are not the - same, once values are projected to avalues, those avalues still have - the structure of the original values (this is necessary, again, to - correctly instantiate the backward functions) - *) - | AAdt of adt_avalue - | ABottom - | ALoan of aloan_content - | ABorrow of aborrow_content - | ASymbolic of aproj - | AIgnored - (** A value which doesn't contain borrows, or which borrows we - don't own and thus ignore *) - -and adt_avalue = { - variant_id : (VariantId.id option[@opaque]); - field_values : typed_avalue list; -} - -(** A loan content as stored in an abstraction. - - Note that the children avalues are independent of the parent avalues. - For instance, the child avalue contained in an {!AMutLoan} will likely - contain other, independent loans. - Keeping track of the hierarchy is not necessary to maintain the borrow graph - (which is the primary role of the abstractions), but it is necessary - to properly instantiate the backward functions when generating the pure - translation. -*) -and aloan_content = - | AMutLoan of (BorrowId.id[@opaque]) * typed_avalue - (** A mutable loan owned by an abstraction. - - Example: - ======== - {[ - fn f<'a>(...) -> &'a mut &'a mut u32; - - let px = f(...); - ]} - - We get (after some symbolic exansion): - {[ - abs0 { - a_mut_loan l0 (a_mut_loan l1) - } - px -> mut_borrow l0 (mut_borrow @s1) - ]} - *) - | ASharedLoan of (BorrowId.Set.t[@opaque]) * typed_value * typed_avalue - (** A shared loan owned by an abstraction. - - Example: - ======== - {[ - fn f<'a>(...) -> &'a u32; - - let px = f(...); - ]} - - We get: - {[ - abs0 { a_shared_loan {l0} @s0 ⊥ } - px -> shared_loan l0 - ]} - *) - | AEndedMutLoan of { - child : typed_avalue; - given_back : typed_avalue; - given_back_meta : mvalue; - } - (** An ended mutable loan in an abstraction. - We need it because abstractions must keep track of the values - we gave back to them, so that we can correctly instantiate - backward functions. - - Rk.: *DO NOT* use [visit_AEndedMutLoan]. If we update the order of - the arguments and you forget to swap them at the level of - [visit_AEndedMutLoan], you will not notice it. - - Example: - ======== - {[ - abs0 { a_mut_loan l0 ⊥ } - x -> mut_borrow l0 (U32 3) - ]} - - After ending [l0]: - - {[ - abs0 { a_ended_mut_loan { given_back = U32 3; child = ⊥; } - x -> ⊥ - ]} - *) - | AEndedSharedLoan of typed_value * typed_avalue - (** Similar to {!AEndedMutLoan} but in this case there are no avalues to - give back. We keep the shared value because it now behaves as a - "regular" value (which contains borrows we might want to end...). - *) - | AIgnoredMutLoan of (BorrowId.id[@opaque]) * typed_avalue - (** An ignored mutable loan. - - We need to keep track of ignored mutable loans, because we may have - to apply projections on the values given back to those loans (say - you have a borrow of type [&'a mut &'b mut], in the abstraction 'b, - the outer loan is ignored, however you need to keep track of it so - that when ending the borrow corresponding to 'a you can correctly - project on the inner value). - - Example: - ======== - {[ - fn f<'a,'b>(...) -> &'a mut &'b mut u32; - let x = f(...); - - > abs'a { a_mut_loan l0 (a_ignored_mut_loan l1 ⊥) } - > abs'b { a_ignored_mut_loan l0 (a_mut_loan l1 ⊥) } - > x -> mut_borrow l0 (mut_borrow l1 @s1) - ]} - *) - | AEndedIgnoredMutLoan of { - child : typed_avalue; - given_back : typed_avalue; - given_back_meta : mvalue; - } - (** Similar to {!AEndedMutLoan}, for ignored loans. - - Rk.: *DO NOT* use [visit_AEndedIgnoredMutLoan]. - See the comment for {!AEndedMutLoan}. - *) - | AIgnoredSharedLoan of typed_avalue - (** An ignored shared loan. - - Example: - ======== - {[ - fn f<'a,'b>(...) -> &'a &'b u32; - let x = f(...); - - > abs'a { a_shared_loan {l0} (shared_borrow l1) (a_ignored_shared_loan ⊥) } - > abs'b { a_ignored_shared_loan (a_shared_loan {l1} @s1 ⊥) } - > x -> shared_borrow l0 - ]} - *) - -(** Note that when a borrow content is ended, it is replaced by ⊥ (while - we need to track ended loans more precisely, especially because of their - children values). - - Note that contrary to {!aloan_content}, here the children avalues are - not independent of the parent avalues. For instance, a value - [AMutBorrow (_, AMutBorrow (_, ...)] (ignoring the types) really is - to be seen like a [mut_borrow ... (mut_borrow ...)]. - - TODO: be more precise about the ignored borrows (keep track of the borrow - ids)? -*) -and aborrow_content = - | AMutBorrow of mvalue * (BorrowId.id[@opaque]) * typed_avalue - (** A mutable borrow owned by an abstraction. - - Is used when an abstraction "consumes" borrows, when giving borrows - as arguments to a function. - - Example: - ======== - {[ - fn f<'a>(px : &'a mut u32); - - > x -> mut_loan l0 - > px -> mut_borrow l0 (U32 0) - - f(move px); - - > x -> mut_loan l0 - > px -> ⊥ - > abs0 { a_mut_borrow l0 (U32 0) } - ]} - - The meta-value stores the initial value on which the projector was - applied, which reduced to this mut borrow. This meta-information - is only used for the synthesis. - TODO: do we really use it actually? - *) - | ASharedBorrow of (BorrowId.id[@opaque]) - (** A shared borrow owned by an abstraction. - - Example: - ======== - {[ - fn f<'a>(px : &'a u32); - - > x -> shared_loan {l0} (U32 0) - > px -> shared_borrow l0 - - f(move px); - - > x -> shared_loan {l0} (U32 0) - > px -> ⊥ - > abs0 { a_shared_borrow l0 } - ]} - *) - | AIgnoredMutBorrow of BorrowId.id option * typed_avalue - (** An ignored mutable borrow. - - We need to keep track of ignored mut borrows because when ending such - borrows, we need to project the loans of the given back value to - insert them in the proper abstractions. - - Note that we need to do so only for borrows consumed by parent - abstractions (hence the optional borrow id). - - TODO: the below explanations are obsolete - - Example: - ======== - {[ - fn f<'a,'b>(ppx : &'a mut &'b mut u32); - - > x -> mut_loan l0 - > px -> mut_loan l1 - > ppx -> mut_borrow l1 (mut_borrow l0 (U32 0)) - - f(move ppx); - - > x -> mut_loan l0 - > px -> mut_loan l1 - > ppx -> ⊥ - > abs'a { a_mut_borrow l1 (a_ignored_mut_borrow None (U32 0)) } // TODO: duplication - > abs'b {parents={abs'a}} { a_ignored_mut_borrow (Some l1) (a_mut_borrow l0 (U32 0)) } - - ... // abs'a ends - - > x -> mut_loan l0 - > px -> @s0 - > ppx -> ⊥ - > abs'b { - > a_ended_ignored_mut_borrow (a_proj_loans (@s0 <: &'b mut u32)) // <-- loan projector - > (a_mut_borrow l0 (U32 0)) - > } - - ... // [@s0] gets expanded to [&mut l2 @s1] - - > x -> mut_loan l0 - > px -> &mut l2 @s1 - > ppx -> ⊥ - > abs'b { - > a_ended_ignored_mut_borrow (a_mut_loan l2) // <-- loan l2 is here - > (a_mut_borrow l0 (U32 0)) - > } - - ]} - - Note that we could use AIgnoredMutLoan in the case the borrow id is not - None, which would allow us to simplify the rules (to not have rules - to specifically handle the case of AIgnoredMutBorrow with Some borrow - id) and also remove the AEndedIgnoredMutBorrow variant. - For now, the rules are implemented and it allows us to make the avalues - more precise and clearer, so we will keep it that way. - - TODO: this is annoying, we are duplicating information. Maybe we - could introduce an "Ignored" value? We have to pay attention to - two things: - - introducing ⊥ when ignoring a value is not always possible, because - we check whether the borrowed value contains ⊥ when giving back a - borrowed value (if it is the case we give back ⊥, otherwise we - introduce a symbolic value). This is necessary when ending nested - borrows with the same lifetime: when ending the inner borrow we - actually give back a value, however when ending the outer borrow - we need to give back ⊥. - TODO: actually we don't do that anymore, we check if the borrowed - avalue contains ended regions (which is cleaner and more robust). - - we may need to remember the precise values given to the - abstraction so that we can properly call the backward functions - when generating the pure translation. - *) - | AEndedMutBorrow of msymbolic_value * typed_avalue - (** The sole purpose of {!AEndedMutBorrow} is to store the (symbolic) value - that we gave back as a meta-value, to help with the synthesis. - - We also remember the child {!avalue} because this structural information - is useful for the synthesis (but not for the symbolic execution): - in practice the child value should only contain ended borrows, ignored - values, bottom values, etc. - *) - | AEndedSharedBorrow - (** We don't really need {!AEndedSharedBorrow}: we simply want to be - precise, and not insert ⊥ when ending borrows. - *) - | AEndedIgnoredMutBorrow of { - child : typed_avalue; - given_back_loans_proj : typed_avalue; - given_back_meta : msymbolic_value; - (** [given_back_meta] is used to store the (symbolic) value we gave back - upon ending the borrow. - - Rk.: *DO NOT* use [visit_AEndedIgnoredMutLoan]. - See the comment for {!AEndedMutLoan}. - *) - } (** See the explanations for {!AIgnoredMutBorrow} *) - | AProjSharedBorrow of abstract_shared_borrows - (** A projected shared borrow. - - When giving shared borrows as arguments to function calls, we - introduce new borrows to keep track of the fact that the function - might reborrow values inside. Note that as shared values are immutable, - we don't really need to remember the structure of the shared values. - - Example: - ======== - Below, when calling [f], we need to introduce one shared borrow per - borrow in the argument. - {[ - fn f<'a,'b>(pppx : &'a &'b &'c mut u32); - - > x -> mut_loan l0 - > px -> shared_loan {l1} (mut_borrow l0 (U32 0)) - > ppx -> shared_loan {l2} (shared_borrow l1) - > pppx -> shared_borrow l2 - - f(move pppx); - - > x -> mut_loan l0 - > px -> shared_loan {l1, l3, l4} (mut_borrow l0 (U32 0)) - > ppx -> shared_loan {l2} (shared_borrow l1) - > pppx -> ⊥ - > abs'a { a_proj_shared_borrow {l2} } - > abs'b { a_proj_shared_borrow {l3} } // l3 reborrows l1 - > abs'c { a_proj_shared_borrow {l4} } // l4 reborrows l0 - ]} - *) - -(* TODO: the type of avalues doesn't make sense for loan avalues: they currently - are typed as [& (mut) T] instead of [T]... -*) -and typed_avalue = { value : avalue; ty : rty } -[@@deriving - show, - visitors - { - name = "iter_typed_avalue"; - variety = "iter"; - ancestors = [ "iter_typed_avalue_base" ]; - nude = true (* Don't inherit {!VisitorsRuntime.iter} *); - concrete = true; - }, - visitors - { - name = "map_typed_avalue"; - variety = "map"; - ancestors = [ "map_typed_avalue_base" ]; - nude = true (* Don't inherit {!VisitorsRuntime.iter} *); - concrete = true; - }] - -(** The kind of an abstraction, which keeps track of its origin *) -type abs_kind = - | FunCall (** The abstraction was introduced because of a function call *) - | SynthInput - (** The abstraction keeps track of the input values of the function - we are currently synthesizing. *) - | SynthRet - (** The abstraction "absorbed" the value returned by the function we - are currently synthesizing *) -[@@deriving show] - -(** Abstractions model the parts in the borrow graph where the borrowing relations - have been abstracted because of a function call. - - In order to model the relations between the borrows, we use "abstraction values", - which are a special kind of value. -*) -type abs = { - abs_id : (AbstractionId.id[@opaque]); - call_id : (FunCallId.id[@opaque]); - (** The identifier of the function call which introduced this - abstraction. This is not used by the symbolic execution: - this is only used for pretty-printing and debugging, in the - symbolic AST, generated by the symbolic execution. - *) - back_id : (RegionGroupId.id[@opaque]); - (** The region group id to which this abstraction is linked. - - In most situations, it gives the id of the backward function (hence - the name), but it is a bit more subtle in the case of synth input - and synth ret abstractions. - - This is not used by the symbolic execution: it is a utility for - the symbolic AST, generated by the symbolic execution. - *) - kind : (abs_kind[@opaque]); - can_end : (bool[@opaque]); - (** Controls whether the region can be ended or not. - - This allows to "pin" some regions, and is useful when generating - backward functions. - - For instance, if we have: [fn f<'a, 'b>(...) -> (&'a mut T, &'b mut T)], - when generating the backward function for 'a, we have to make sure we - don't need to end the return region for 'b (if it is the case, it means - the function doesn't borrow check). - *) - parents : (AbstractionId.Set.t[@opaque]); (** The parent abstractions *) - original_parents : (AbstractionId.id list[@opaque]); - (** The original list of parents, ordered. This is used for synthesis. *) - regions : (RegionId.Set.t[@opaque]); (** Regions owned by this abstraction *) - ancestors_regions : (RegionId.Set.t[@opaque]); - (** Union of the regions owned by this abstraction's ancestors (not - including the regions of this abstraction itself) *) - avalues : typed_avalue list; (** The values in this abstraction *) -} -[@@deriving - show, - visitors - { - name = "iter_abs"; - variety = "iter"; - ancestors = [ "iter_typed_avalue" ]; - nude = true (* Don't inherit {!VisitorsRuntime.iter} *); - concrete = true; - }, - visitors - { - name = "map_abs"; - variety = "map"; - ancestors = [ "map_typed_avalue" ]; - nude = true (* Don't inherit {!VisitorsRuntime.iter} *); - concrete = true; - }] - -(** A symbolic expansion - - A symbolic expansion doesn't represent a value, but rather an operation - that we apply to values. - - TODO: this should rather be name "expanded_symbolic" - *) -type symbolic_expansion = - | SeConcrete of constant_value - | SeAdt of (VariantId.id option * symbolic_value list) - | SeMutRef of BorrowId.id * symbolic_value - | SeSharedRef of BorrowId.Set.t * symbolic_value diff --git a/src/ValuesUtils.ml b/src/ValuesUtils.ml deleted file mode 100644 index 72d7abe0..00000000 --- a/src/ValuesUtils.ml +++ /dev/null @@ -1,121 +0,0 @@ -open Utils -open TypesUtils -open Types -open Values -module TA = TypesAnalysis - -(** Utility exception *) -exception FoundSymbolicValue of symbolic_value - -let mk_unit_value : typed_value = - { value = Adt { variant_id = None; field_values = [] }; ty = mk_unit_ty } - -let mk_typed_value (ty : ety) (value : value) : typed_value = { value; ty } -let mk_bottom (ty : ety) : typed_value = { value = Bottom; ty } - -(** Box a value *) -let mk_box_value (v : typed_value) : typed_value = - let box_ty = mk_box_ty v.ty in - let box_v = Adt { variant_id = None; field_values = [ v ] } in - mk_typed_value box_ty box_v - -let is_bottom (v : value) : bool = match v with Bottom -> true | _ -> false - -let is_symbolic (v : value) : bool = - match v with Symbolic _ -> true | _ -> false - -let as_symbolic (v : value) : symbolic_value = - match v with Symbolic s -> s | _ -> failwith "Unexpected" - -let as_mut_borrow (v : typed_value) : BorrowId.id * typed_value = - match v.value with - | Borrow (MutBorrow (bid, bv)) -> (bid, bv) - | _ -> failwith "Unexpected" - -(** Check if a value contains a borrow *) -let borrows_in_value (v : typed_value) : bool = - let obj = - object - inherit [_] iter_typed_value - method! visit_borrow_content _env _ = raise Found - end - in - (* We use exceptions *) - try - obj#visit_typed_value () v; - false - with Found -> true - -(** Check if a value contains inactivated mutable borrows *) -let inactivated_in_value (v : typed_value) : bool = - let obj = - object - inherit [_] iter_typed_value - method! visit_InactivatedMutBorrow _env _ = raise Found - end - in - (* We use exceptions *) - try - obj#visit_typed_value () v; - false - with Found -> true - -(** Check if a value contains a loan *) -let loans_in_value (v : typed_value) : bool = - let obj = - object - inherit [_] iter_typed_value - method! visit_loan_content _env _ = raise Found - end - in - (* We use exceptions *) - try - obj#visit_typed_value () v; - false - with Found -> true - -(** Check if a value contains outer loans (i.e., loans which are not in borrwed - values. *) -let outer_loans_in_value (v : typed_value) : bool = - let obj = - object - inherit [_] iter_typed_value - method! visit_loan_content _env _ = raise Found - method! visit_borrow_content _ _ = () - end - in - (* We use exceptions *) - try - obj#visit_typed_value () v; - false - with Found -> true - -let find_first_primitively_copyable_sv_with_borrows (type_infos : TA.type_infos) - (v : typed_value) : symbolic_value option = - (* The visitor *) - let obj = - object - inherit [_] iter_typed_value - - method! visit_Symbolic _ sv = - let ty = sv.sv_ty in - if ty_is_primitively_copyable ty && ty_has_borrows type_infos ty then - raise (FoundSymbolicValue sv) - else () - end - in - (* Small helper *) - try - obj#visit_typed_value () v; - None - with FoundSymbolicValue sv -> Some sv - -(** Strip the outer shared loans in a value. - Ex.: - [shared_loan {l0, l1} (3 : u32, shared_loan {l2} (4 : u32))] ~~> - [(3 : u32, shared_loan {l2} (4 : u32))] - *) -let rec value_strip_shared_loans (v : typed_value) : typed_value = - match v.value with - | Loan (SharedLoan (_, v')) -> value_strip_shared_loans v' - | _ -> v diff --git a/src/driver.ml b/src/driver.ml deleted file mode 100644 index ae9d238a..00000000 --- a/src/driver.ml +++ /dev/null @@ -1,208 +0,0 @@ -open Aeneas.LlbcOfJson -open Aeneas.Logging -open Aeneas.Print -module T = Aeneas.Types -module A = Aeneas.LlbcAst -module I = Aeneas.Interpreter -module EL = Easy_logging.Logging -module TA = Aeneas.TypesAnalysis -module Micro = Aeneas.PureMicroPasses -module Print = Aeneas.Print -module PrePasses = Aeneas.PrePasses -module Translate = Aeneas.Translate - -(* This is necessary to have a backtrace when raising exceptions - for some - * reason, the -g option doesn't work. - * TODO: run with OCAMLRUNPARAM=b=1? *) -let () = Printexc.record_backtrace true - -let usage = - Printf.sprintf - {|Aeneas: verification of Rust programs by translation to pure lambda calculus - -Usage: %s [OPTIONS] FILE -|} - Sys.argv.(0) - -let () = - (* Measure start time *) - let start_time = Unix.gettimeofday () in - - (* Read the command line arguments *) - let dest_dir = ref "" in - let decompose_monads = ref false in - let unfold_monads = ref true in - let filter_useless_calls = ref true in - let filter_useless_functions = ref true in - let test_units = ref false in - let test_trans_units = ref false in - let no_decreases_clauses = ref false in - let no_state = ref false in - let template_decreases_clauses = ref false in - let no_split_files = ref false in - let no_check_inv = ref false in - - let spec = - [ - ("-dest", Arg.Set_string dest_dir, " Specify the output directory"); - ( "-decompose-monads", - Arg.Set decompose_monads, - " Decompose the monadic let-bindings.\n\n\ - \ Introduces a temporary variable which is later decomposed,\n\ - \ when the pattern on the left of the monadic let is not a \n\ - \ variable.\n\ - \ \n\ - \ Example:\n\ - \ `(x, y) <-- f (); ...` ~~>\n\ - \ `tmp <-- f (); let (x, y) = tmp in ...`\n\ - \ " ); - ( "-unfold-monads", - Arg.Set unfold_monads, - " Unfold the monadic let-bindings to matches" ); - ( "-filter-useless-calls", - Arg.Set filter_useless_calls, - " Filter the useless function calls, when possible" ); - ( "-filter-useless-funs", - Arg.Set filter_useless_functions, - " Filter the useless forward/backward functions" ); - ( "-test-units", - Arg.Set test_units, - " Test the unit functions with the concrete interpreter" ); - ( "-test-trans-units", - Arg.Set test_trans_units, - " Test the translated unit functions with the target theorem\n\ - \ prover's normalizer" ); - ( "-no-decreases-clauses", - Arg.Set no_decreases_clauses, - " Do not add decrease clauses to the recursive definitions" ); - ( "-no-state", - Arg.Set no_state, - " Do not use state-error monads, simply use error monads" ); - ( "-template-clauses", - Arg.Set template_decreases_clauses, - " Generate templates for the required decreases clauses, in a\n\ - \ dedicated file. Incompatible with \ - -no-decreases-clauses" ); - ( "-no-split-files", - Arg.Set no_split_files, - " Don't split the definitions between different files for types,\n\ - \ functions, etc." ); - ( "-no-check-inv", - Arg.Set no_check_inv, - " Deactivate the invariant sanity checks performed at every step of\n\ - \ evaluation. Dramatically saves speed." ); - ] - in - (* Sanity check: -template-clauses ==> not -no-decrease-clauses *) - assert ((not !no_decreases_clauses) || not !template_decreases_clauses); - - let spec = Arg.align spec in - let filenames = ref [] in - let add_filename f = filenames := f :: !filenames in - Arg.parse spec add_filename usage; - let fail () = - print_string usage; - exit 1 - in - (* Retrieve and check the filename *) - let filename = - match !filenames with - | [ f ] -> - (* TODO: update the extension *) - if not (Filename.check_suffix f ".llbc") then ( - print_string "Unrecognized file extension"; - fail ()) - else if not (Sys.file_exists f) then ( - print_string "File not found"; - fail ()) - else f - | _ -> - (* For now, we only process one file at a time *) - print_string usage; - exit 1 - in - (* Check the destination directory *) - let dest_dir = - if !dest_dir = "" then Filename.dirname filename else !dest_dir - in - - (* Set up the logging - for now we use default values - TODO: use the - * command-line arguments *) - (* By setting a level for the main_logger_handler, we filter everything *) - Easy_logging.Handlers.set_level main_logger_handler EL.Debug; - main_log#set_level EL.Info; - llbc_of_json_logger#set_level EL.Info; - pre_passes_log#set_level EL.Info; - interpreter_log#set_level EL.Info; - statements_log#set_level EL.Info; - paths_log#set_level EL.Info; - expressions_log#set_level EL.Info; - expansion_log#set_level EL.Info; - borrows_log#set_level EL.Info; - invariants_log#set_level EL.Info; - pure_utils_log#set_level EL.Info; - symbolic_to_pure_log#set_level EL.Info; - pure_micro_passes_log#set_level EL.Info; - pure_to_extract_log#set_level EL.Info; - translate_log#set_level EL.Info; - - (* Load the module *) - let json = Yojson.Basic.from_file filename in - match llbc_crate_of_json json with - | Error s -> - main_log#error "error: %s\n" s; - exit 1 - | Ok m -> - (* Logging *) - main_log#linfo (lazy ("Imported: " ^ filename)); - main_log#ldebug (lazy ("\n" ^ Print.Module.module_to_string m ^ "\n")); - - (* Apply the pre-passes *) - let m = PrePasses.apply_passes m in - - (* Some options for the execution *) - let eval_config = - { - C.check_invariants = not !no_check_inv; - greedy_expand_symbolics_with_borrows = true; - allow_bottom_below_borrow = true; - return_unit_end_abs_with_no_loans = true; - } - in - - (* Test the unit functions with the concrete interpreter *) - if !test_units then I.Test.test_unit_functions eval_config m; - - (* Evaluate the symbolic interpreter on the functions, ignoring the - * functions which contain loops - TODO: remove *) - let synthesize = true in - I.Test.test_functions_symbolic eval_config synthesize m; - - (* Translate the functions *) - let test_unit_functions = !test_trans_units in - let micro_passes_config = - { - Micro.decompose_monadic_let_bindings = !decompose_monads; - unfold_monadic_let_bindings = !unfold_monads; - filter_useless_monadic_calls = !filter_useless_calls; - filter_useless_functions = !filter_useless_functions; - } - in - let trans_config = - { - Translate.eval_config; - mp_config = micro_passes_config; - split_files = not !no_split_files; - test_unit_functions; - extract_decreases_clauses = not !no_decreases_clauses; - extract_template_decreases_clauses = !template_decreases_clauses; - use_state = not !no_state; - } - in - Translate.translate_module filename dest_dir trans_config m; - - (* Print total elapsed time *) - log#linfo - (lazy - (Printf.sprintf "Total execution time: %f seconds" - (Unix.gettimeofday () -. start_time))) diff --git a/src/dune b/src/dune deleted file mode 100644 index e8b53fc5..00000000 --- a/src/dune +++ /dev/null @@ -1,48 +0,0 @@ -;; core: for Core.Unix.mkdir_p - -(executable - (name driver) - (public_name aeneas_driver) - (package aeneas) - (preprocess - (pps ppx_deriving.show ppx_deriving.ord visitors.ppx)) - (libraries ppx_deriving yojson zarith easy_logging core_unix aeneas) - (modules driver)) - -(library - (name aeneas) ;; The name as used in the project - (public_name aeneas) ;; The name as revealed to the projects importing this library - (preprocess - (pps ppx_deriving.show ppx_deriving.ord visitors.ppx)) - (libraries ppx_deriving yojson zarith easy_logging core_unix) - (modules Assumed Collections ConstStrings Contexts Cps Crates Errors - Expressions ExpressionsUtils ExtractToFStar FunsAnalysis Identifiers - InterpreterBorrowsCore InterpreterBorrows InterpreterExpansion - InterpreterExpressions Interpreter InterpreterPaths InterpreterProjectors - InterpreterStatements InterpreterUtils Invariants LlbcAst LlbcAstUtils - LlbcOfJson Logging Meta Names OfJsonBasic PrePasses Print PrintPure - PureMicroPasses Pure PureToExtract PureTypeCheck PureUtils Scalars - StringUtils Substitute SymbolicAst SymbolicToPure SynthesizeSymbolic - TranslateCore Translate TypesAnalysis Types TypesUtils Utils Values - ValuesUtils)) - -(documentation - (package aeneas)) - -(env - (dev - (flags - :standard - -safe-string - -g - ;-dsource - -warn-error - -5-8-9-11-14-33-20-21-26-27-39)) - (release - (flags - :standard - -safe-string - -g - ;-dsource - -warn-error - -5-8-9-11-14-33-20-21-26-27-39))) |