diff options
Diffstat (limited to 'compiler')
57 files changed, 24491 insertions, 0 deletions
diff --git a/compiler/.ocamlformat b/compiler/.ocamlformat new file mode 100644 index 00000000..b0ae150e --- /dev/null +++ b/compiler/.ocamlformat @@ -0,0 +1 @@ +doc-comments=before
\ No newline at end of file diff --git a/compiler/Assumed.ml b/compiler/Assumed.ml new file mode 100644 index 00000000..cb089c08 --- /dev/null +++ b/compiler/Assumed.ml @@ -0,0 +1,300 @@ +(** This module contains various utilities for the assumed functions. + + Note that [Box::free] is peculiar: we don't really handle it as a function, + because it is legal to free a box whose boxed value is [⊥] (it often + happens that we move a value out of a box before freeing this box). + Semantically speaking, we thus handle [Box::free] as a value drop and + not as a function call, and thus never need its signature. + + TODO: implementing the concrete evaluation functions for the assumed + functions is really annoying (see + [InterpreterStatements.eval_non_local_function_call_concrete]). + I think it should be possible, in most situations, to write bodies which + model the behaviour of those unsafe functions. For instance, [Box::deref_mut] + should simply be: + {[ + fn deref_mut<'a, T>(x : &'a mut Box<T>) -> &'a mut T { + &mut ( *x ) // box dereferencement is a primitive operation + } + ]} + + For vectors, we could "cheat" by using the index as a field index (vectors + would be encoded as ADTs with a variable number of fields). Of course, it + would require a bit of engineering, but it would probably be quite lightweight + in the end. + {[ + Vec::get_mut<'a,T>(v : &'a mut Vec<T>, i : usize) -> &'a mut T { + &mut ( ( *x ).i ) + } + ]} + *) + +open Names +open TypesUtils +module T = Types +module A = LlbcAst + +module Sig = struct + (** A few utilities *) + + let rvar_id_0 = T.RegionVarId.of_int 0 + let rvar_0 : T.RegionVarId.id T.region = T.Var rvar_id_0 + let rg_id_0 = T.RegionGroupId.of_int 0 + let tvar_id_0 = T.TypeVarId.of_int 0 + let tvar_0 : T.sty = T.TypeVar tvar_id_0 + + (** Region 'a of id 0 *) + let region_param_0 : T.region_var = { T.index = rvar_id_0; name = Some "'a" } + + (** Region group: [{ parent={}; regions:{'a of id 0} }] *) + let region_group_0 : T.region_var_group = + { T.id = rg_id_0; regions = [ rvar_id_0 ]; parents = [] } + + (** Type parameter [T] of id 0 *) + let type_param_0 : T.type_var = { T.index = tvar_id_0; name = "T" } + + let mk_ref_ty (r : T.RegionVarId.id T.region) (ty : T.sty) (is_mut : bool) : + T.sty = + let ref_kind = if is_mut then T.Mut else T.Shared in + mk_ref_ty r ty ref_kind + + (** [fn<T>(&'a mut T, T) -> T] *) + let mem_replace_sig : A.fun_sig = + (* The signature fields *) + let region_params = [ region_param_0 ] (* <'a> *) in + let regions_hierarchy = [ region_group_0 ] (* [{<'a>}] *) in + let type_params = [ type_param_0 ] (* <T> *) in + let inputs = + [ mk_ref_ty rvar_0 tvar_0 true (* &'a mut T *); tvar_0 (* T *) ] + in + let output = tvar_0 (* T *) in + { + region_params; + num_early_bound_regions = 0; + regions_hierarchy; + type_params; + inputs; + output; + } + + (** [fn<T>(T) -> Box<T>] *) + let box_new_sig : A.fun_sig = + { + region_params = []; + num_early_bound_regions = 0; + regions_hierarchy = []; + type_params = [ type_param_0 ] (* <T> *); + inputs = [ tvar_0 (* T *) ]; + output = mk_box_ty tvar_0 (* Box<T> *); + } + + (** [fn<T>(Box<T>) -> ()] *) + let box_free_sig : A.fun_sig = + { + region_params = []; + num_early_bound_regions = 0; + regions_hierarchy = []; + type_params = [ type_param_0 ] (* <T> *); + inputs = [ mk_box_ty tvar_0 (* Box<T> *) ]; + output = mk_unit_ty (* () *); + } + + (** Helper for [Box::deref_shared] and [Box::deref_mut]. + Returns: + [fn<'a, T>(&'a (mut) Box<T>) -> &'a (mut) T] + *) + let box_deref_gen_sig (is_mut : bool) : A.fun_sig = + (* The signature fields *) + let region_params = [ region_param_0 ] in + let regions_hierarchy = [ region_group_0 ] (* <'a> *) in + { + region_params; + num_early_bound_regions = 0; + regions_hierarchy; + type_params = [ type_param_0 ] (* <T> *); + inputs = + [ mk_ref_ty rvar_0 (mk_box_ty tvar_0) is_mut (* &'a (mut) Box<T> *) ]; + output = mk_ref_ty rvar_0 tvar_0 is_mut (* &'a (mut) T *); + } + + (** [fn<'a, T>(&'a Box<T>) -> &'a T] *) + let box_deref_shared_sig = box_deref_gen_sig false + + (** [fn<'a, T>(&'a mut Box<T>) -> &'a mut T] *) + let box_deref_mut_sig = box_deref_gen_sig true + + (** [fn<T>() -> Vec<T>] *) + let vec_new_sig : A.fun_sig = + let region_params = [] in + let regions_hierarchy = [] in + let type_params = [ type_param_0 ] (* <T> *) in + let inputs = [] in + let output = mk_vec_ty tvar_0 (* Vec<T> *) in + { + region_params; + num_early_bound_regions = 0; + regions_hierarchy; + type_params; + inputs; + output; + } + + (** [fn<T>(&'a mut Vec<T>, T)] *) + let vec_push_sig : A.fun_sig = + (* The signature fields *) + let region_params = [ region_param_0 ] in + let regions_hierarchy = [ region_group_0 ] (* <'a> *) in + let type_params = [ type_param_0 ] (* <T> *) in + let inputs = + [ + mk_ref_ty rvar_0 (mk_vec_ty tvar_0) true (* &'a mut Vec<T> *); + tvar_0 (* T *); + ] + in + let output = mk_unit_ty (* () *) in + { + region_params; + num_early_bound_regions = 0; + regions_hierarchy; + type_params; + inputs; + output; + } + + (** [fn<T>(&'a mut Vec<T>, usize, T)] *) + let vec_insert_sig : A.fun_sig = + (* The signature fields *) + let region_params = [ region_param_0 ] in + let regions_hierarchy = [ region_group_0 ] (* <'a> *) in + let type_params = [ type_param_0 ] (* <T> *) in + let inputs = + [ + mk_ref_ty rvar_0 (mk_vec_ty tvar_0) true (* &'a mut Vec<T> *); + mk_usize_ty (* usize *); + tvar_0 (* T *); + ] + in + let output = mk_unit_ty (* () *) in + { + region_params; + num_early_bound_regions = 0; + regions_hierarchy; + type_params; + inputs; + output; + } + + (** [fn<T>(&'a Vec<T>) -> usize] *) + let vec_len_sig : A.fun_sig = + (* The signature fields *) + let region_params = [ region_param_0 ] in + let regions_hierarchy = [ region_group_0 ] (* <'a> *) in + let type_params = [ type_param_0 ] (* <T> *) in + let inputs = + [ mk_ref_ty rvar_0 (mk_vec_ty tvar_0) false (* &'a Vec<T> *) ] + in + let output = mk_usize_ty (* usize *) in + { + region_params; + num_early_bound_regions = 0; + regions_hierarchy; + type_params; + inputs; + output; + } + + (** Helper: + [fn<T>(&'a (mut) Vec<T>, usize) -> &'a (mut) T] + *) + let vec_index_gen_sig (is_mut : bool) : A.fun_sig = + (* The signature fields *) + let region_params = [ region_param_0 ] in + let regions_hierarchy = [ region_group_0 ] (* <'a> *) in + let type_params = [ type_param_0 ] (* <T> *) in + let inputs = + [ + mk_ref_ty rvar_0 (mk_vec_ty tvar_0) is_mut (* &'a (mut) Vec<T> *); + mk_usize_ty (* usize *); + ] + in + let output = mk_ref_ty rvar_0 tvar_0 is_mut (* &'a (mut) T *) in + { + region_params; + num_early_bound_regions = 0; + regions_hierarchy; + type_params; + inputs; + output; + } + + (** [fn<T>(&'a Vec<T>, usize) -> &'a T] *) + let vec_index_shared_sig : A.fun_sig = vec_index_gen_sig false + + (** [fn<T>(&'a mut Vec<T>, usize) -> &'a mut T] *) + let vec_index_mut_sig : A.fun_sig = vec_index_gen_sig true +end + +type assumed_info = A.assumed_fun_id * A.fun_sig * bool * name + +(** The list of assumed functions and all their information: + - their signature + - a boolean indicating whether the function can fail or not + - their name + + Rk.: following what is written above, we don't include [Box::free]. + + Remark about the vector functions: for [Vec::len] to be correct and return + a [usize], we have to make sure that vectors are bounded by the max usize. + Followingly, [Vec::push] is monadic. + *) +let assumed_infos : assumed_info list = + let deref_pre = [ "core"; "ops"; "deref" ] in + let vec_pre = [ "alloc"; "vec"; "Vec" ] in + let index_pre = [ "core"; "ops"; "index" ] in + [ + (A.Replace, Sig.mem_replace_sig, false, to_name [ "core"; "mem"; "replace" ]); + (BoxNew, Sig.box_new_sig, false, to_name [ "alloc"; "boxed"; "Box"; "new" ]); + ( BoxFree, + Sig.box_free_sig, + false, + to_name [ "alloc"; "boxed"; "Box"; "free" ] ); + ( BoxDeref, + Sig.box_deref_shared_sig, + false, + to_name (deref_pre @ [ "Deref"; "deref" ]) ); + ( BoxDerefMut, + Sig.box_deref_mut_sig, + false, + to_name (deref_pre @ [ "DerefMut"; "deref_mut" ]) ); + (VecNew, Sig.vec_new_sig, false, to_name (vec_pre @ [ "new" ])); + (VecPush, Sig.vec_push_sig, true, to_name (vec_pre @ [ "push" ])); + (VecInsert, Sig.vec_insert_sig, true, to_name (vec_pre @ [ "insert" ])); + (VecLen, Sig.vec_len_sig, false, to_name (vec_pre @ [ "len" ])); + ( VecIndex, + Sig.vec_index_shared_sig, + true, + to_name (index_pre @ [ "Index"; "index" ]) ); + ( VecIndexMut, + Sig.vec_index_mut_sig, + true, + to_name (index_pre @ [ "IndexMut"; "index_mut" ]) ); + ] + +let get_assumed_info (id : A.assumed_fun_id) : assumed_info = + match List.find_opt (fun (id', _, _, _) -> id = id') assumed_infos with + | Some info -> info + | None -> + raise + (Failure ("get_assumed_info: not found: " ^ A.show_assumed_fun_id id)) + +let get_assumed_sig (id : A.assumed_fun_id) : A.fun_sig = + let _, sg, _, _ = get_assumed_info id in + sg + +let get_assumed_name (id : A.assumed_fun_id) : fun_name = + let _, _, _, name = get_assumed_info id in + name + +let assumed_can_fail (id : A.assumed_fun_id) : bool = + let _, _, b, _ = get_assumed_info id in + b diff --git a/compiler/Collections.ml b/compiler/Collections.ml new file mode 100644 index 00000000..0933b3e4 --- /dev/null +++ b/compiler/Collections.ml @@ -0,0 +1,378 @@ +(** The following file redefines several modules like Map or Set. *) + +module F = Format + +module List = struct + include List + + (** Split a list at a given index. + + [split_at ls i] splits [ls] into two lists where the first list has + length [i]. + + Raise [Failure] if the list is too short. + *) + let rec split_at (ls : 'a list) (i : int) = + if i < 0 then raise (Invalid_argument "split_at take positive integers") + else if i = 0 then ([], ls) + else + match ls with + | [] -> + raise + (Failure "The int given to split_at should be <= the list's length") + | x :: ls' -> + let ls1, ls2 = split_at ls' (i - 1) in + (x :: ls1, ls2) + + (** Pop the last element of a list + + Raise [Failure] if the list is empty. + *) + let rec pop_last (ls : 'a list) : 'a list * 'a = + match ls with + | [] -> raise (Failure "The list is empty") + | [ x ] -> ([], x) + | x :: ls -> + let ls, last = pop_last ls in + (x :: ls, last) + + (** Return the n first elements of the list *) + let prefix (n : int) (ls : 'a list) : 'a list = fst (split_at ls n) + + (** Iter and link the iterations. + + Iterate over a list, but call a function between every two elements + (but not before the first element, and not after the last). + *) + let iter_link (link : unit -> unit) (f : 'a -> unit) (ls : 'a list) : unit = + let rec iter ls = + match ls with + | [] -> () + | [ x ] -> f x + | x :: y :: ls -> + f x; + link (); + iter (y :: ls) + in + iter ls + + (** Fold and link the iterations. + + Similar to {!iter_link} but for fold left operations. + *) + let fold_left_link (link : unit -> unit) (f : 'a -> 'b -> 'a) (init : 'a) + (ls : 'b list) : 'a = + let rec fold (acc : 'a) (ls : 'b list) : 'a = + match ls with + | [] -> acc + | [ x ] -> f acc x + | x :: y :: ls -> + let acc = f acc x in + link (); + fold acc (y :: ls) + in + fold init ls + + let to_cons_nil (ls : 'a list) : 'a = + match ls with + | [ x ] -> x + | _ -> raise (Failure "The list should have length exactly one") + + let pop (ls : 'a list) : 'a * 'a list = + match ls with + | x :: ls' -> (x, ls') + | _ -> raise (Failure "The list should have length > 0") +end + +module type OrderedType = sig + include Map.OrderedType + + val to_string : t -> string + val pp_t : Format.formatter -> t -> unit + val show_t : t -> string +end + +(** Ordered string *) +module OrderedString : OrderedType with type t = string = struct + include String + + let to_string s = s + let pp_t fmt s = Format.pp_print_string fmt s + let show_t s = s +end + +module type Map = sig + include Map.S + + val add_list : (key * 'a) list -> 'a t -> 'a t + val of_list : (key * 'a) list -> 'a t + + (** "Simple" pretty printing function. + + Is useful when we need to customize a bit [show_t], but without using + something as burdensome as [pp_t]. + + [to_string (Some indent) m] prints [m] by breaking line after every binding + and inserting [indent]. + *) + val to_string : string option -> ('a -> string) -> 'a t -> string + + val pp : (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a t -> unit + val show : ('a -> string) -> 'a t -> string +end + +module MakeMap (Ord : OrderedType) : Map with type key = Ord.t = struct + module Map = Map.Make (Ord) + include Map + + let add_list bl m = List.fold_left (fun s (key, e) -> add key e s) m bl + let of_list bl = add_list bl empty + + let to_string indent_opt a_to_string m = + let indent, break = + match indent_opt with Some indent -> (indent, "\n") | None -> ("", " ") + in + let sep = "," ^ break in + let ls = + Map.fold + (fun key v ls -> + (indent ^ Ord.to_string key ^ " -> " ^ a_to_string v) :: ls) + m [] + in + match ls with + | [] -> "{}" + | _ -> "{" ^ break ^ String.concat sep (List.rev ls) ^ break ^ "}" + + let pp (pp_a : Format.formatter -> 'a -> unit) (fmt : Format.formatter) + (m : 'a t) : unit = + let pp_string = F.pp_print_string fmt in + let pp_space () = F.pp_print_space fmt () in + pp_string "{"; + F.pp_open_box fmt 2; + Map.iter + (fun key x -> + Ord.pp_t fmt key; + pp_space (); + pp_string "->"; + pp_space (); + pp_a fmt x; + pp_string ","; + F.pp_print_break fmt 1 0) + m; + F.pp_close_box fmt (); + F.pp_print_break fmt 0 0; + pp_string "}" + + let show show_a m = to_string None show_a m +end + +module type Set = sig + include Set.S + + val add_list : elt list -> t -> t + val of_list : elt list -> t + + (** "Simple" pretty printing function. + + Is useful when we need to customize a bit [show_t], but without using + something as burdensome as [pp_t]. + + [to_string (Some indent) s] prints [s] by breaking line after every element + and inserting [indent]. + *) + val to_string : string option -> t -> string + + val pp : Format.formatter -> t -> unit + val show : t -> string + val pairwise_distinct : elt list -> bool +end + +module MakeSet (Ord : OrderedType) : Set with type elt = Ord.t = struct + module Set = Set.Make (Ord) + include Set + + let add_list bl s = List.fold_left (fun s e -> add e s) s bl + let of_list bl = add_list bl empty + + let to_string indent_opt m = + let indent, break = + match indent_opt with Some indent -> (indent, "\n") | None -> ("", " ") + in + let sep = "," ^ break in + let ls = Set.fold (fun v ls -> (indent ^ Ord.to_string v) :: ls) m [] in + match ls with + | [] -> "{}" + | _ -> "{" ^ break ^ String.concat sep (List.rev ls) ^ break ^ "}" + + let pp (fmt : Format.formatter) (m : t) : unit = + let pp_string = F.pp_print_string fmt in + pp_string "{"; + F.pp_open_box fmt 2; + Set.iter + (fun x -> + Ord.pp_t fmt x; + pp_string ","; + F.pp_print_break fmt 1 0) + m; + F.pp_close_box fmt (); + F.pp_print_break fmt 0 0; + pp_string "}" + + let show s = to_string None s + + let pairwise_distinct ls = + let s = ref empty in + let rec check ls = + match ls with + | [] -> true + | x :: ls' -> + if mem x !s then false + else ( + s := add x !s; + check ls') + in + check ls +end + +(** A map where the bindings are injective (i.e., if two keys are distinct, + their bindings are distinct). + + This is useful for instance when generating mappings from our internal + identifiers to names (i.e., strings) when generating code, in order to + make sure that we don't have potentially dangerous collisions. + *) +module type InjMap = sig + type key + type elem + type t + + val empty : t + val is_empty : t -> bool + val mem : key -> t -> bool + val add : key -> elem -> t -> t + val singleton : key -> elem -> t + val remove : key -> t -> t + val compare : (elem -> elem -> int) -> t -> t -> int + val equal : (elem -> elem -> bool) -> t -> t -> bool + val iter : (key -> elem -> unit) -> t -> unit + val fold : (key -> elem -> 'b -> 'b) -> t -> 'b -> 'b + val for_all : (key -> elem -> bool) -> t -> bool + val exists : (key -> elem -> bool) -> t -> bool + val filter : (key -> elem -> bool) -> t -> t + val partition : (key -> elem -> bool) -> t -> t * t + val cardinal : t -> int + val bindings : t -> (key * elem) list + val min_binding : t -> key * elem + val min_binding_opt : t -> (key * elem) option + val max_binding : t -> key * elem + val max_binding_opt : t -> (key * elem) option + val choose : t -> key * elem + val choose_opt : t -> (key * elem) option + val split : key -> t -> t * elem option * t + val find : key -> t -> elem + val find_opt : key -> t -> elem option + val find_first : (key -> bool) -> t -> key * elem + val find_first_opt : (key -> bool) -> t -> (key * elem) option + val find_last : (key -> bool) -> t -> key * elem + val find_last_opt : (key -> bool) -> t -> (key * elem) option + val to_seq : t -> (key * elem) Seq.t + val to_seq_from : key -> t -> (key * elem) Seq.t + val add_seq : (key * elem) Seq.t -> t -> t + val of_seq : (key * elem) Seq.t -> t + val add_list : (key * elem) list -> t -> t + val of_list : (key * elem) list -> t +end + +(** See {!InjMap} *) +module MakeInjMap (Key : OrderedType) (Elem : OrderedType) : + InjMap with type key = Key.t with type elem = Elem.t = struct + module Map = MakeMap (Key) + module Set = MakeSet (Elem) + + type key = Key.t + type elem = Elem.t + type t = { map : elem Map.t; elems : Set.t } + + let empty = { map = Map.empty; elems = Set.empty } + let is_empty m = Map.is_empty m.map + let mem k m = Map.mem k m.map + + let add k e m = + assert (not (Set.mem e m.elems)); + { map = Map.add k e m.map; elems = Set.add e m.elems } + + let singleton k e = { map = Map.singleton k e; elems = Set.singleton e } + + let remove k m = + match Map.find_opt k m.map with + | None -> m + | Some x -> { map = Map.remove k m.map; elems = Set.remove x m.elems } + + let compare f m1 m2 = Map.compare f m1.map m2.map + let equal f m1 m2 = Map.equal f m1.map m2.map + let iter f m = Map.iter f m.map + let fold f m x = Map.fold f m.map x + let for_all f m = Map.for_all f m.map + let exists f m = Map.exists f m.map + + (** Small helper *) + let bindings_to_elems_set (bls : (key * elem) list) : Set.t = + let elems = List.map snd bls in + let elems = List.fold_left (fun s e -> Set.add e s) Set.empty elems in + elems + + (** Small helper *) + let map_to_elems_set (map : elem Map.t) : Set.t = + bindings_to_elems_set (Map.bindings map) + + (** Small helper *) + let map_to_t (map : elem Map.t) : t = + let elems = map_to_elems_set map in + { map; elems } + + let filter f m = + let map = Map.filter f m.map in + let elems = map_to_elems_set map in + { map; elems } + + let partition f m = + let map1, map2 = Map.partition f m.map in + (map_to_t map1, map_to_t map2) + + let cardinal m = Map.cardinal m.map + let bindings m = Map.bindings m.map + let min_binding m = Map.min_binding m.map + let min_binding_opt m = Map.min_binding_opt m.map + let max_binding m = Map.max_binding m.map + let max_binding_opt m = Map.max_binding_opt m.map + let choose m = Map.choose m.map + let choose_opt m = Map.choose_opt m.map + + let split k m = + let l, data, r = Map.split k m.map in + let l = map_to_t l in + let r = map_to_t r in + (l, data, r) + + let find k m = Map.find k m.map + let find_opt k m = Map.find_opt k m.map + let find_first k m = Map.find_first k m.map + let find_first_opt k m = Map.find_first_opt k m.map + let find_last k m = Map.find_last k m.map + let find_last_opt k m = Map.find_last_opt k m.map + let to_seq m = Map.to_seq m.map + let to_seq_from k m = Map.to_seq_from k m.map + + let rec add_seq s m = + (* Note that it is important to check that we don't add bindings mapping + * to the same element *) + match s () with + | Seq.Nil -> m + | Seq.Cons ((k, e), s) -> + let m = add k e m in + add_seq s m + + let of_seq s = add_seq s empty + let add_list ls m = List.fold_left (fun m (key, elem) -> add key elem m) m ls + let of_list ls = add_list ls empty +end diff --git a/compiler/ConstStrings.ml b/compiler/ConstStrings.ml new file mode 100644 index 00000000..ae169a2e --- /dev/null +++ b/compiler/ConstStrings.ml @@ -0,0 +1,7 @@ +(** Some utilities *) + +(** Basename for state variables (introduced when using state-error monads) *) +let state_basename = "st" + +(** ADT constructor prefix (used when pretty-printing) *) +let constructor_prefix = "Mk" diff --git a/compiler/Contexts.ml b/compiler/Contexts.ml new file mode 100644 index 00000000..510976f4 --- /dev/null +++ b/compiler/Contexts.ml @@ -0,0 +1,472 @@ +open Types +open Values +open LlbcAst +module V = Values +open ValuesUtils + +(** Some global counters. + + Note that those counters were initially stored in {!eval_ctx} values, + but it proved better to make them global and stateful: + - when branching (and thus executing on several paths with different + contexts) it is better to really have unique ids everywhere (and + not have fresh ids shared by several contexts even though introduced + after the branching) because at some point we might need to merge the + different contexts + - also, it is a lot more convenient to not store those counters in contexts + objects + + ============= + **WARNING**: + ============= + Pay attention when playing with closures, as you may not always generate + fresh identifiers without noticing it, especially when using type abbreviations. + For instance, consider the following: + {[ + type fun_type = unit -> ... + fn f x : fun_type = + let id = fresh_id () in + ... + + let g = f x in // <-- the fresh identifier gets generated here + let x1 = g () in // <-- no fresh generation here + let x2 = g () in + ... + ]} + + This is why, in such cases, we often introduce all the inputs, even + when they are not used (which happens!). + {[ + fn f x : fun_type = + fun .. -> + let id = fresh_id () in + ... + ]} + + Note that in practice, we never reuse closures, except when evaluating + a branching in the execution (which is fine, because the branches evaluate + independentely of each other). Still, it is always a good idea to be + defensive. + + However, the same problem arises with logging. + + Also, a more defensive way would be to not use global references, and + store the counters in the evaluation context. This is actually what was + originally done, before we updated the code to use global counters because + it proved more convenient (and even before updating the code of the + interpreter to use CPS). + *) + +let symbolic_value_id_counter, fresh_symbolic_value_id = + SymbolicValueId.fresh_stateful_generator () + +let borrow_id_counter, fresh_borrow_id = BorrowId.fresh_stateful_generator () +let region_id_counter, fresh_region_id = RegionId.fresh_stateful_generator () + +let abstraction_id_counter, fresh_abstraction_id = + AbstractionId.fresh_stateful_generator () + +let fun_call_id_counter, fresh_fun_call_id = + FunCallId.fresh_stateful_generator () + +(** We shouldn't need to reset the global counters, but it might be good to + do it from time to time, for instance every time we start evaluating/ + synthesizing a function. + + The reasons are manifold: + - it might prevent the counters from overflowing (although this seems + extremely unlikely - as a side node: we have overflow checks to make + sure the synthesis doesn't get impacted by potential overflows) + - most importantly, it allows to always manipulate low values, which + is always a lot more readable when debugging + *) +let reset_global_counters () = + symbolic_value_id_counter := SymbolicValueId.generator_zero; + borrow_id_counter := BorrowId.generator_zero; + region_id_counter := RegionId.generator_zero; + abstraction_id_counter := AbstractionId.generator_zero; + fun_call_id_counter := FunCallId.generator_zero + +(** A binder used in an environment, to map a variable to a value *) +type binder = { + index : VarId.id; (** Unique variable identifier *) + name : string option; (** Possible name *) +} +[@@deriving show] + +(** Environment value: mapping from variable to value, abstraction (only + used in symbolic mode) or stack frame delimiter. + + TODO: rename Var (-> Binding?) + *) +type env_elem = + | Var of (binder option[@opaque]) * typed_value + (** Variable binding - the binder is None if the variable is a dummy variable + (we use dummy variables to store temporaries while doing bookkeeping such + as ending borrows for instance). *) + | Abs of abs + | Frame +[@@deriving + show, + visitors + { + name = "iter_env_elem"; + variety = "iter"; + ancestors = [ "iter_abs" ]; + nude = true (* Don't inherit {!VisitorsRuntime.iter} *); + concrete = true; + }, + visitors + { + name = "map_env_elem"; + variety = "map"; + ancestors = [ "map_abs" ]; + nude = true (* Don't inherit {!VisitorsRuntime.iter} *); + concrete = true; + }] + +type env = env_elem list +[@@deriving + show, + visitors + { + name = "iter_env"; + variety = "iter"; + ancestors = [ "iter_env_elem" ]; + nude = true (* Don't inherit {!VisitorsRuntime.iter} *); + concrete = true; + }, + visitors + { + name = "map_env"; + variety = "map"; + ancestors = [ "map_env_elem" ]; + nude = true (* Don't inherit {!VisitorsRuntime.iter} *); + concrete = true; + }] + +type interpreter_mode = ConcreteMode | SymbolicMode [@@deriving show] + +type config = { + mode : interpreter_mode; + (** Concrete mode (interpreter) or symbolic mode (for synthesis) **) + check_invariants : bool; + (** Check that invariants are maintained whenever we execute a statement *) + greedy_expand_symbolics_with_borrows : bool; + (** Expand all symbolic values containing borrows upon introduction - allows + to use restrict ourselves to a simpler model for the projectors over + symbolic values. + The interpreter fails if doing this requires to do a branching (because + we need to expand an enumeration with strictly more than one variant) + or if we need to expand a recursive type (because this leads to looping). + *) + allow_bottom_below_borrow : bool; + (** Experimental. + + We sometimes want to temporarily break the invariant that there is no + bottom value below a borrow. If this value is true, we don't check + the invariant, and the rule becomes: we can't end a borrow *if* it contains + a bottom value. The consequence is that it becomes ok to temporarily + have bottom below a borrow, if we put something else inside before ending + the borrow. + + For instance, when evaluating an assignment, we move the value which + will be overwritten then do some administrative tasks with the borrows, + then move the rvalue to its destination. We currently want to be able + to check the invariants every time we end a borrow/an abstraction, + meaning at intermediate steps of the assignment where the invariants + might actually be broken. + *) + return_unit_end_abs_with_no_loans : bool; + (** If a function doesn't return any borrows, we can immediately call + its backward functions. If this option is on, whenever we call a + function *and* this function returns unit, we immediately end all the + abstractions which are introduced and don't contain loans. This can be + useful to make the code cleaner (the backward function is introduced + where the function call happened) and make sure all forward functions + with no return value are followed by a backward function. + *) +} +[@@deriving show] + +(** See {!config} *) +type partial_config = { + check_invariants : bool; + greedy_expand_symbolics_with_borrows : bool; + allow_bottom_below_borrow : bool; + return_unit_end_abs_with_no_loans : bool; +} + +let config_of_partial (mode : interpreter_mode) (config : partial_config) : + config = + { + mode; + check_invariants = config.check_invariants; + greedy_expand_symbolics_with_borrows = + config.greedy_expand_symbolics_with_borrows; + allow_bottom_below_borrow = config.allow_bottom_below_borrow; + return_unit_end_abs_with_no_loans = config.return_unit_end_abs_with_no_loans; + } + +type type_context = { + type_decls_groups : Crates.type_declaration_group TypeDeclId.Map.t; + type_decls : type_decl TypeDeclId.Map.t; + type_infos : TypesAnalysis.type_infos; +} +[@@deriving show] + +type fun_context = { fun_decls : fun_decl FunDeclId.Map.t } [@@deriving show] + +type global_context = { global_decls : global_decl GlobalDeclId.Map.t } +[@@deriving show] + +(** Evaluation context *) +type eval_ctx = { + type_context : type_context; + fun_context : fun_context; + global_context : global_context; + type_vars : type_var list; + env : env; + ended_regions : RegionId.Set.t; +} +[@@deriving show] + +let lookup_type_var (ctx : eval_ctx) (vid : TypeVarId.id) : type_var = + TypeVarId.nth ctx.type_vars vid + +let opt_binder_has_vid (bv : binder option) (vid : VarId.id) : bool = + match bv with Some bv -> bv.index = vid | None -> false + +let ctx_lookup_binder (ctx : eval_ctx) (vid : VarId.id) : binder = + (* TOOD: we might want to stop at the end of the frame *) + let rec lookup env = + match env with + | [] -> + raise (Invalid_argument ("Variable not found: " ^ VarId.to_string vid)) + | Var (var, _) :: env' -> + if opt_binder_has_vid var vid then Option.get var else lookup env' + | (Abs _ | Frame) :: env' -> lookup env' + in + lookup ctx.env + +(** TODO: make this more efficient with maps *) +let ctx_lookup_type_decl (ctx : eval_ctx) (tid : TypeDeclId.id) : type_decl = + TypeDeclId.Map.find tid ctx.type_context.type_decls + +(** TODO: make this more efficient with maps *) +let ctx_lookup_fun_decl (ctx : eval_ctx) (fid : FunDeclId.id) : fun_decl = + FunDeclId.Map.find fid ctx.fun_context.fun_decls + +(** TODO: make this more efficient with maps *) +let ctx_lookup_global_decl (ctx : eval_ctx) (gid : GlobalDeclId.id) : + global_decl = + GlobalDeclId.Map.find gid ctx.global_context.global_decls + +(** Retrieve a variable's value in an environment *) +let env_lookup_var_value (env : env) (vid : VarId.id) : typed_value = + (* We take care to stop at the end of current frame: different variables + in different frames can have the same id! + *) + let rec lookup env = + match env with + | [] -> failwith "Unexpected" + | Var (var, v) :: env' -> + if opt_binder_has_vid var vid then v else lookup env' + | Abs _ :: env' -> lookup env' + | Frame :: _ -> failwith "End of frame" + in + lookup env + +(** Retrieve a variable's value in an evaluation context *) +let ctx_lookup_var_value (ctx : eval_ctx) (vid : VarId.id) : typed_value = + env_lookup_var_value ctx.env vid + +(** Update a variable's value in an environment + + This is a helper function: it can break invariants and doesn't perform + any check. +*) +let env_update_var_value (env : env) (vid : VarId.id) (nv : typed_value) : env = + (* We take care to stop at the end of current frame: different variables + in different frames can have the same id! + *) + let rec update env = + match env with + | [] -> failwith "Unexpected" + | Var (var, v) :: env' -> + if opt_binder_has_vid var vid then Var (var, nv) :: env' + else Var (var, v) :: update env' + | Abs abs :: env' -> Abs abs :: update env' + | Frame :: _ -> failwith "End of frame" + in + update env + +let var_to_binder (var : var) : binder = { index = var.index; name = var.name } + +(** Update a variable's value in an evaluation context. + + This is a helper function: it can break invariants and doesn't perform + any check. +*) +let ctx_update_var_value (ctx : eval_ctx) (vid : VarId.id) (nv : typed_value) : + eval_ctx = + { ctx with env = env_update_var_value ctx.env vid nv } + +(** Push a variable in the context's environment. + + Checks that the pushed variable and its value have the same type (this + is important). +*) +let ctx_push_var (ctx : eval_ctx) (var : var) (v : typed_value) : eval_ctx = + assert (var.var_ty = v.ty); + let bv = var_to_binder var in + { ctx with env = Var (Some bv, v) :: ctx.env } + +(** Push a list of variables. + + Checks that the pushed variables and their values have the same type (this + is important). +*) +let ctx_push_vars (ctx : eval_ctx) (vars : (var * typed_value) list) : eval_ctx + = + assert ( + List.for_all + (fun (var, (value : typed_value)) -> var.var_ty = value.ty) + vars); + let vars = + List.map (fun (var, value) -> Var (Some (var_to_binder var), value)) vars + in + let vars = List.rev vars in + { ctx with env = List.append vars ctx.env } + +(** Push a dummy variable in the context's environment. *) +let ctx_push_dummy_var (ctx : eval_ctx) (v : typed_value) : eval_ctx = + { ctx with env = Var (None, v) :: ctx.env } + +(** Pop the first dummy variable from a context's environment. *) +let ctx_pop_dummy_var (ctx : eval_ctx) : eval_ctx * typed_value = + let rec pop_var (env : env) : env * typed_value = + match env with + | [] -> failwith "Could not find a dummy variable" + | Var (None, v) :: env -> (env, v) + | ee :: env -> + let env, v = pop_var env in + (ee :: env, v) + in + let env, v = pop_var ctx.env in + ({ ctx with env }, v) + +(** Read the first dummy variable in a context's environment. *) +let ctx_read_first_dummy_var (ctx : eval_ctx) : typed_value = + let rec read_var (env : env) : typed_value = + match env with + | [] -> failwith "Could not find a dummy variable" + | Var (None, v) :: _env -> v + | _ :: env -> read_var env + in + read_var ctx.env + +(** Push an uninitialized variable (which thus maps to {!Values.Bottom}) *) +let ctx_push_uninitialized_var (ctx : eval_ctx) (var : var) : eval_ctx = + ctx_push_var ctx var (mk_bottom var.var_ty) + +(** Push a list of uninitialized variables (which thus map to {!Values.Bottom}) *) +let ctx_push_uninitialized_vars (ctx : eval_ctx) (vars : var list) : eval_ctx = + let vars = List.map (fun v -> (v, mk_bottom v.var_ty)) vars in + ctx_push_vars ctx vars + +let env_lookup_abs (env : env) (abs_id : V.AbstractionId.id) : V.abs = + let rec lookup env = + match env with + | [] -> failwith "Unexpected" + | Var (_, _) :: env' -> lookup env' + | Abs abs :: env' -> if abs.abs_id = abs_id then abs else lookup env' + | Frame :: env' -> lookup env' + in + lookup env + +let ctx_lookup_abs (ctx : eval_ctx) (abs_id : V.AbstractionId.id) : V.abs = + env_lookup_abs ctx.env abs_id + +let ctx_type_decl_is_rec (ctx : eval_ctx) (id : TypeDeclId.id) : bool = + let decl_group = TypeDeclId.Map.find id ctx.type_context.type_decls_groups in + match decl_group with Crates.Rec _ -> true | Crates.NonRec _ -> false + +(** Visitor to iterate over the values in the *current* frame *) +class ['self] iter_frame = + object (self : 'self) + inherit [_] V.iter_abs + + method visit_Var : 'acc -> binder option -> typed_value -> unit = + fun acc _vid v -> self#visit_typed_value acc v + + method visit_Abs : 'acc -> abs -> unit = + fun acc abs -> self#visit_abs acc abs + + method visit_env_elem : 'acc -> env_elem -> unit = + fun acc em -> + match em with + | Var (vid, v) -> self#visit_Var acc vid v + | Abs abs -> self#visit_Abs acc abs + | Frame -> failwith "Unreachable" + + method visit_env : 'acc -> env -> unit = + fun acc env -> + match env with + | [] -> () + | Frame :: _ -> (* We stop here *) () + | em :: env -> + self#visit_env_elem acc em; + self#visit_env acc env + end + +(** Visitor to map over the values in the *current* frame *) +class ['self] map_frame_concrete = + object (self : 'self) + inherit [_] V.map_abs + + method visit_Var : 'acc -> binder option -> typed_value -> env_elem = + fun acc vid v -> + let v = self#visit_typed_value acc v in + Var (vid, v) + + method visit_Abs : 'acc -> abs -> env_elem = + fun acc abs -> Abs (self#visit_abs acc abs) + + method visit_env_elem : 'acc -> env_elem -> env_elem = + fun acc em -> + match em with + | Var (vid, v) -> self#visit_Var acc vid v + | Abs abs -> self#visit_Abs acc abs + | Frame -> failwith "Unreachable" + + method visit_env : 'acc -> env -> env = + fun acc env -> + match env with + | [] -> [] + | Frame :: env -> (* We stop here *) Frame :: env + | em :: env -> + let em = self#visit_env_elem acc em in + let env = self#visit_env acc env in + em :: env + end + +(** Visitor to iterate over the values in a context *) +class ['self] iter_eval_ctx = + object (_self : 'self) + inherit [_] iter_env as super + + method visit_eval_ctx : 'acc -> eval_ctx -> unit = + fun acc ctx -> super#visit_env acc ctx.env + end + +(** Visitor to map the values in a context *) +class ['self] map_eval_ctx = + object (_self : 'self) + inherit [_] map_env as super + + method visit_eval_ctx : 'acc -> eval_ctx -> eval_ctx = + fun acc ctx -> + let env = super#visit_env acc ctx.env in + { ctx with env } + end diff --git a/compiler/Cps.ml b/compiler/Cps.ml new file mode 100644 index 00000000..c2c0363b --- /dev/null +++ b/compiler/Cps.ml @@ -0,0 +1,193 @@ +(** This module defines various utilities to write the interpretation functions + in continuation passing style. *) + +module T = Types +module V = Values +module C = Contexts +module SA = SymbolicAst + +(** TODO: change the name *) +type eval_error = EPanic + +(** Result of evaluating a statement *) +type statement_eval_res = + | Unit + | Break of int + | Continue of int + | Return + | Panic + +(** Synthesized expresssion - dummy for now *) +type sexpr = SOne | SList of sexpr list + +type eval_result = SA.expression option + +(** Continuation function *) +type m_fun = C.eval_ctx -> eval_result + +(** Continuation taking another continuation as parameter *) +type cm_fun = m_fun -> m_fun + +(** Continuation taking a typed value as parameter - TODO: use more *) +type typed_value_m_fun = V.typed_value -> m_fun + +(** Continuation taking another continuation as parameter and a typed + value as parameter. + *) +type typed_value_cm_fun = V.typed_value -> cm_fun + +(** Type of a continuation used when evaluating a statement *) +type st_m_fun = statement_eval_res -> m_fun + +(** Type of a continuation used when evaluating a statement *) +type st_cm_fun = st_m_fun -> m_fun + +(** Convert a unit function to a cm function *) +let unit_to_cm_fun (f : C.eval_ctx -> unit) : cm_fun = + fun cf ctx -> + f ctx; + cf ctx + +(** *) +let update_to_cm_fun (f : C.eval_ctx -> C.eval_ctx) : cm_fun = + fun cf ctx -> + let ctx = f ctx in + cf ctx + +(** Composition of functions taking continuations as parameters. + We tried to make this as general as possible. *) +let comp (f : 'c -> 'd -> 'e) (g : ('a -> 'b) -> 'c) : ('a -> 'b) -> 'd -> 'e = + fun cf ctx -> f (g cf) ctx + +let comp_unit (f : cm_fun) (g : C.eval_ctx -> unit) : cm_fun = + comp f (unit_to_cm_fun g) + +let comp_update (f : cm_fun) (g : C.eval_ctx -> C.eval_ctx) : cm_fun = + comp f (update_to_cm_fun g) + +(** This is just a test, to check that {!comp} is general enough to handle a case + where a function must compute a value and give it to the continuation. + It happens for functions like {!InterpreterExpressions.eval_operand}. + + Keeping this here also makes it a good reference, when one wants to figure + out the signatures he should use for such a composition. + *) +let comp_ret_val (f : (V.typed_value -> m_fun) -> m_fun) + (g : m_fun -> V.typed_value -> m_fun) : cm_fun = + comp f g + +let apply (f : cm_fun) (g : m_fun) : m_fun = fun ctx -> f g ctx +let id_cm_fun : cm_fun = fun cf ctx -> cf ctx + +(** If we have a list of [inputs] of type ['a list] and a function [f] which + evaluates one element of type ['a] to compute a result of type ['b] before + giving it to a continuation, the following function performs a fold operation: + it evaluates all the inputs one by one by accumulating the results in a list, + and gives the list to a continuation. + + Note that we make sure that the results are listed in the order in + which they were computed (the first element of the list is the result + of applying [f] to the first element of the inputs). + + See the unit test below for an illustration. + *) +let fold_left_apply_continuation (f : 'a -> ('c -> 'd) -> 'c -> 'd) + (inputs : 'a list) (cf : 'c -> 'd) : 'c -> 'd = + let rec eval_list (inputs : 'a list) (cf : 'c -> 'd) : 'c -> 'd = + fun ctx -> + match inputs with + | [] -> cf ctx + | x :: inputs -> comp (f x) (fun cf -> eval_list inputs cf) cf ctx + in + eval_list inputs cf + +(** Unit test/example for {!fold_left_apply_continuation} *) +let _ = + fold_left_apply_continuation + (fun x cf (ctx : int) -> cf (ctx + x)) + [ 1; 20; 300; 4000 ] + (fun (ctx : int) -> assert (ctx = 4321)) + 0 + +(** If we have a list of [inputs] of type ['a list] and a function [f] which + evaluates one element of type ['a] to compute a result of type ['b] before + giving it to a continuation, the following function performs a fold operation: + it evaluates all the inputs one by one by accumulating the results in a list, + and gives the list to a continuation. + + Note that we make sure that the results are listed in the order in + which they were computed (the first element of the list is the result + of applying [f] to the first element of the inputs). + + See the unit test below for an illustration. + *) +let fold_left_list_apply_continuation (f : 'a -> ('b -> 'c -> 'd) -> 'c -> 'd) + (inputs : 'a list) (cf : 'b list -> 'c -> 'd) : 'c -> 'd = + let rec eval_list (inputs : 'a list) (cf : 'b list -> 'c -> 'd) + (outputs : 'b list) : 'c -> 'd = + fun ctx -> + match inputs with + | [] -> cf (List.rev outputs) ctx + | x :: inputs -> + comp (f x) (fun cf v -> eval_list inputs cf (v :: outputs)) cf ctx + in + eval_list inputs cf [] + +(** Unit test/example for {!fold_left_list_apply_continuation} *) +let _ = + fold_left_list_apply_continuation + (fun x cf (ctx : unit) -> cf (10 + x) ctx) + [ 0; 1; 2; 3; 4 ] + (fun values _ctx -> assert (values = [ 10; 11; 12; 13; 14 ])) + () + +(** Composition of functions taking continuations as parameters. + + We sometimes have the following situation, where we want to compose three + functions [send], [transmit] and [receive] such that: + - those three functions take continuations as parameters + - [send] generates a value and gives it to its continuation + - [receive] expects a value (so we can compose [send] and [receive] like + so: [comp send receive]) + - [transmit] doesn't expect any value and needs to be called between [send] + and [receive] + + In this situation, we need to take the value given by [send] and "transmit" + it to [receive]. + + This is what this function does (see the unit test below for an illustration). + *) +let comp_transmit (f : ('v -> 'm) -> 'n) (g : 'm -> 'm) : ('v -> 'm) -> 'n = + fun cf -> f (fun v -> g (cf v)) + +(** Example of use of {!comp_transmit} *) +let () = + let return3 (cf : int -> unit -> unit) (ctx : unit) = cf 3 ctx in + let do_nothing (cf : unit -> unit) (ctx : unit) = cf ctx in + let consume3 (x : int) (ctx : unit) : unit = + assert (x = 3); + ctx + in + let cc = comp_transmit return3 do_nothing in + let cc = cc consume3 in + cc () + +(** Sometimes, we want to compose a function with a continuation which checks + its computed value and its updated context, before transmitting them + *) +let comp_check_value (f : ('v -> 'ctx -> 'a) -> 'ctx -> 'b) + (g : 'v -> 'ctx -> unit) : ('v -> 'ctx -> 'a) -> 'ctx -> 'b = + fun cf -> + f (fun v ctx -> + g v ctx; + cf v ctx) + +(** This case is similar to {!comp_check_value}, but even simpler (we only check + the context) + *) +let comp_check_ctx (f : ('ctx -> 'a) -> 'ctx -> 'b) (g : 'ctx -> unit) : + ('ctx -> 'a) -> 'ctx -> 'b = + fun cf -> + f (fun ctx -> + g ctx; + cf ctx) diff --git a/compiler/Crates.ml b/compiler/Crates.ml new file mode 100644 index 00000000..844afb94 --- /dev/null +++ b/compiler/Crates.ml @@ -0,0 +1,90 @@ +open Types +open LlbcAst + +type 'id g_declaration_group = NonRec of 'id | Rec of 'id list +[@@deriving show] + +type type_declaration_group = TypeDeclId.id g_declaration_group +[@@deriving show] + +type fun_declaration_group = FunDeclId.id g_declaration_group [@@deriving show] + +(** Module declaration. Globals cannot be mutually recursive. *) +type declaration_group = + | Type of type_declaration_group + | Fun of fun_declaration_group + | Global of GlobalDeclId.id +[@@deriving show] + +type llbc_crate = { + name : string; + declarations : declaration_group list; + types : type_decl list; + functions : fun_decl list; + globals : global_decl list; +} +(** LLBC crate *) + +let compute_defs_maps (c : llbc_crate) : + type_decl TypeDeclId.Map.t + * fun_decl FunDeclId.Map.t + * global_decl GlobalDeclId.Map.t = + let types_map = + List.fold_left + (fun m (def : type_decl) -> TypeDeclId.Map.add def.def_id def m) + TypeDeclId.Map.empty c.types + in + let funs_map = + List.fold_left + (fun m (def : fun_decl) -> FunDeclId.Map.add def.def_id def m) + FunDeclId.Map.empty c.functions + in + let globals_map = + List.fold_left + (fun m (def : global_decl) -> GlobalDeclId.Map.add def.def_id def m) + GlobalDeclId.Map.empty c.globals + in + (types_map, funs_map, globals_map) + +(** Split a module's declarations between types, functions and globals *) +let split_declarations (decls : declaration_group list) : + type_declaration_group list + * fun_declaration_group list + * GlobalDeclId.id list = + let rec split decls = + match decls with + | [] -> ([], [], []) + | d :: decls' -> ( + let types, funs, globals = split decls' in + match d with + | Type decl -> (decl :: types, funs, globals) + | Fun decl -> (types, decl :: funs, globals) + | Global decl -> (types, funs, decl :: globals)) + in + split decls + +(** Split a module's declarations into three maps from type/fun/global ids to + declaration groups. + *) +let split_declarations_to_group_maps (decls : declaration_group list) : + type_declaration_group TypeDeclId.Map.t + * fun_declaration_group FunDeclId.Map.t + * GlobalDeclId.Set.t = + let module G (M : Map.S) = struct + let add_group (map : M.key g_declaration_group M.t) + (group : M.key g_declaration_group) : M.key g_declaration_group M.t = + match group with + | NonRec id -> M.add id group map + | Rec ids -> List.fold_left (fun map id -> M.add id group map) map ids + + let create_map (groups : M.key g_declaration_group list) : + M.key g_declaration_group M.t = + List.fold_left add_group M.empty groups + end in + let types, funs, globals = split_declarations decls in + let module TG = G (TypeDeclId.Map) in + let types = TG.create_map types in + let module FG = G (FunDeclId.Map) in + let funs = FG.create_map funs in + let globals = GlobalDeclId.Set.of_list globals in + (types, funs, globals) diff --git a/compiler/Errors.ml b/compiler/Errors.ml new file mode 100644 index 00000000..31a53cf4 --- /dev/null +++ b/compiler/Errors.ml @@ -0,0 +1,2 @@ +exception IntegerOverflow of unit +exception Unimplemented diff --git a/compiler/Expressions.ml b/compiler/Expressions.ml new file mode 100644 index 00000000..e2eaf1e7 --- /dev/null +++ b/compiler/Expressions.ml @@ -0,0 +1,118 @@ +open Types +open Values + +type field_proj_kind = + | ProjAdt of TypeDeclId.id * VariantId.id option + | ProjOption of VariantId.id + (** Option is an assumed type, coming from the standard library *) + | ProjTuple of int +[@@deriving show] +(* arity of the tuple *) + +type projection_elem = + | Deref + | DerefBox + | Field of field_proj_kind * FieldId.id +[@@deriving show] + +type projection = projection_elem list [@@deriving show] +type place = { var_id : VarId.id; projection : projection } [@@deriving show] +type borrow_kind = Shared | Mut | TwoPhaseMut [@@deriving show] + +type unop = + | Not + | Neg + | Cast of integer_type * integer_type + (** Cast an integer from a source type to a target type *) +[@@deriving show, ord] + +(** A binary operation + + Note that we merge checked binops and unchecked binops: we perform a + micro-pass on the MIR AST to remove the assertions introduced by rustc, + and later extract the binops which can fail (addition, substraction, etc.) + or have preconditions (division, remainder...) to monadic functions. + *) +type binop = + | BitXor + | BitAnd + | BitOr + | Eq + | Lt + | Le + | Ne + | Ge + | Gt + | Div + | Rem + | Add + | Sub + | Mul + | Shl + | Shr +[@@deriving show, ord] + +let all_binops = + [ + BitXor; + BitAnd; + BitOr; + Eq; + Lt; + Le; + Ne; + Ge; + Gt; + Div; + Rem; + Add; + Sub; + Mul; + Shl; + Shr; + ] + +type operand = + | Copy of place + | Move of place + | Constant of ety * constant_value +[@@deriving show] + +(** An aggregated ADT. + + Note that ADTs are desaggregated at some point in MIR. For instance, if + we have in Rust: + {[ + let ls = Cons(hd, tl); + ]} + + In MIR we have (yes, the discriminant update happens *at the end* for some + reason): + {[ + (ls as Cons).0 = move hd; + (ls as Cons).1 = move tl; + discriminant(ls) = 0; // assuming [Cons] is the variant of index 0 + ]} + + Note that in our semantics, we handle both cases (in case of desaggregated + initialization, [ls] is initialized to [⊥], then this [⊥] is expanded to + [Cons (⊥, ⊥)] upon the first assignment, at which point we can initialize + the field 0, etc.). + *) +type aggregate_kind = + | AggregatedTuple + | AggregatedOption of VariantId.id * ety + (* TODO: AggregatedOption should be merged with AggregatedAdt *) + | AggregatedAdt of + TypeDeclId.id * VariantId.id option * erased_region list * ety list +[@@deriving show] + +(* TODO: move the aggregate kind to operands *) +type rvalue = + | Use of operand + | Ref of place * borrow_kind + | UnaryOp of unop * operand + | BinaryOp of binop * operand * operand + | Discriminant of place + | Aggregate of aggregate_kind * operand list +[@@deriving show] diff --git a/compiler/ExpressionsUtils.ml b/compiler/ExpressionsUtils.ml new file mode 100644 index 00000000..c3ccfb15 --- /dev/null +++ b/compiler/ExpressionsUtils.ml @@ -0,0 +1,10 @@ +module E = Expressions + +let unop_can_fail (unop : E.unop) : bool = + match unop with Neg | Cast _ -> true | Not -> false + +let binop_can_fail (binop : E.binop) : bool = + match binop with + | BitXor | BitAnd | BitOr | Eq | Lt | Le | Ne | Ge | Gt -> false + | Div | Rem | Add | Sub | Mul -> true + | Shl | Shr -> raise Errors.Unimplemented diff --git a/compiler/ExtractToFStar.ml b/compiler/ExtractToFStar.ml new file mode 100644 index 00000000..5d212941 --- /dev/null +++ b/compiler/ExtractToFStar.ml @@ -0,0 +1,1638 @@ +(** Extract to F* *) + +open Errors +open Pure +open PureUtils +open TranslateCore +open PureToExtract +open StringUtils +module F = Format + +(** A qualifier for a type definition. + + Controls whether we should use [type ...] or [and ...] (for mutually + recursive datatypes). + *) +type type_decl_qualif = + | Type (** [type t = ...] *) + | And (** [type t0 = ... and t1 = ...] *) + | AssumeType (** [assume type t] *) + | TypeVal (** In an fsti: [val t : Type0] *) + +(** A qualifier for function definitions. + + Controls whether we should use [let ...], [let rec ...] or [and ...], + or only generate a declaration with [val] or [assume val] + *) +type fun_decl_qualif = Let | LetRec | And | Val | AssumeVal + +let fun_decl_qualif_keyword (qualif : fun_decl_qualif) : string = + match qualif with + | Let -> "let" + | LetRec -> "let rec" + | And -> "and" + | Val -> "val" + | AssumeVal -> "assume val" + +(** Small helper to compute the name of an int type *) +let fstar_int_name (int_ty : integer_type) = + match int_ty with + | Isize -> "isize" + | I8 -> "i8" + | I16 -> "i16" + | I32 -> "i32" + | I64 -> "i64" + | I128 -> "i128" + | Usize -> "usize" + | U8 -> "u8" + | U16 -> "u16" + | U32 -> "u32" + | U64 -> "u64" + | U128 -> "u128" + +(** Small helper to compute the name of a unary operation *) +let fstar_unop_name (unop : unop) : string = + match unop with + | Not -> "not" + | Neg int_ty -> fstar_int_name int_ty ^ "_neg" + | Cast _ -> raise (Failure "Unsupported") + +(** Small helper to compute the name of a binary operation (note that many + binary operations like "less than" are extracted to primitive operations, + like [<]. + *) +let fstar_named_binop_name (binop : E.binop) (int_ty : integer_type) : string = + let binop = + match binop with + | Div -> "div" + | Rem -> "rem" + | Add -> "add" + | Sub -> "sub" + | Mul -> "mul" + | _ -> raise (Failure "Unreachable") + in + fstar_int_name int_ty ^ "_" ^ binop + +(** A list of keywords/identifiers used in F* and with which we want to check + collision. *) +let fstar_keywords = + let named_unops = + fstar_unop_name Not + :: List.map (fun it -> fstar_unop_name (Neg it)) T.all_signed_int_types + in + let named_binops = [ E.Div; Rem; Add; Sub; Mul ] in + let named_binops = + List.concat + (List.map + (fun bn -> + List.map (fun it -> fstar_named_binop_name bn it) T.all_int_types) + named_binops) + in + let misc = + [ + "let"; + "rec"; + "in"; + "fn"; + "val"; + "int"; + "nat"; + "list"; + "FStar"; + "FStar.Mul"; + "type"; + "match"; + "with"; + "assert"; + "assert_norm"; + "Type0"; + "unit"; + "not"; + "scalar_cast"; + ] + in + List.concat [ named_unops; named_binops; misc ] + +let fstar_assumed_adts : (assumed_ty * string) list = + [ (State, "state"); (Result, "result"); (Option, "option"); (Vec, "vec") ] + +let fstar_assumed_structs : (assumed_ty * string) list = [] + +let fstar_assumed_variants : (assumed_ty * VariantId.id * string) list = + [ + (Result, result_return_id, "Return"); + (Result, result_fail_id, "Fail"); + (Option, option_some_id, "Some"); + (Option, option_none_id, "None"); + ] + +let fstar_assumed_functions : + (A.assumed_fun_id * T.RegionGroupId.id option * string) list = + let rg0 = Some T.RegionGroupId.zero in + [ + (Replace, None, "mem_replace_fwd"); + (Replace, rg0, "mem_replace_back"); + (VecNew, None, "vec_new"); + (VecPush, None, "vec_push_fwd") (* Shouldn't be used *); + (VecPush, rg0, "vec_push_back"); + (VecInsert, None, "vec_insert_fwd") (* Shouldn't be used *); + (VecInsert, rg0, "vec_insert_back"); + (VecLen, None, "vec_len"); + (VecIndex, None, "vec_index_fwd"); + (VecIndex, rg0, "vec_index_back") (* shouldn't be used *); + (VecIndexMut, None, "vec_index_mut_fwd"); + (VecIndexMut, rg0, "vec_index_mut_back"); + ] + +let fstar_names_map_init = + { + keywords = fstar_keywords; + assumed_adts = fstar_assumed_adts; + assumed_structs = fstar_assumed_structs; + assumed_variants = fstar_assumed_variants; + assumed_functions = fstar_assumed_functions; + } + +let fstar_extract_unop (extract_expr : bool -> texpression -> unit) + (fmt : F.formatter) (inside : bool) (unop : unop) (arg : texpression) : unit + = + match unop with + | Not | Neg _ -> + let unop = fstar_unop_name unop in + if inside then F.pp_print_string fmt "("; + F.pp_print_string fmt unop; + F.pp_print_space fmt (); + extract_expr true arg; + if inside then F.pp_print_string fmt ")" + | Cast (src, tgt) -> + (* The source type is an implicit parameter *) + if inside then F.pp_print_string fmt "("; + F.pp_print_string fmt "scalar_cast"; + F.pp_print_space fmt (); + F.pp_print_string fmt + (StringUtils.capitalize_first_letter + (PrintPure.integer_type_to_string src)); + F.pp_print_space fmt (); + F.pp_print_string fmt + (StringUtils.capitalize_first_letter + (PrintPure.integer_type_to_string tgt)); + F.pp_print_space fmt (); + extract_expr true arg; + if inside then F.pp_print_string fmt ")" + +let fstar_extract_binop (extract_expr : bool -> texpression -> unit) + (fmt : F.formatter) (inside : bool) (binop : E.binop) + (int_ty : integer_type) (arg0 : texpression) (arg1 : texpression) : unit = + if inside then F.pp_print_string fmt "("; + (* Some binary operations have a special treatment *) + (match binop with + | Eq | Lt | Le | Ne | Ge | Gt -> + let binop = + match binop with + | Eq -> "=" + | Lt -> "<" + | Le -> "<=" + | Ne -> "<>" + | Ge -> ">=" + | Gt -> ">" + | _ -> raise (Failure "Unreachable") + in + extract_expr false arg0; + F.pp_print_space fmt (); + F.pp_print_string fmt binop; + F.pp_print_space fmt (); + extract_expr false arg1 + | Div | Rem | Add | Sub | Mul -> + let binop = fstar_named_binop_name binop int_ty in + F.pp_print_string fmt binop; + F.pp_print_space fmt (); + extract_expr false arg0; + F.pp_print_space fmt (); + extract_expr false arg1 + | BitXor | BitAnd | BitOr | Shl | Shr -> raise Unimplemented); + if inside then F.pp_print_string fmt ")" + +(** + [ctx]: we use the context to lookup type definitions, to retrieve type names. + This is used to compute variable names, when they have no basenames: in this + case we use the first letter of the type name. + + [variant_concatenate_type_name]: if true, add the type name as a prefix + to the variant names. + Ex.: + In Rust: + {[ + enum List = { + Cons(u32, Box<List>),x + Nil, + } + ]} + + F*, if option activated: + {[ + type list = + | ListCons : u32 -> list -> list + | ListNil : list + ]} + + F*, if option not activated: + {[ + type list = + | Cons : u32 -> list -> list + | Nil : list + ]} + + Rk.: this should be true by default, because in Rust all the variant names + are actively uniquely identifier by the type name [List::Cons(...)], while + in other languages it is not necessarily the case, and thus clashes can mess + up type checking. Note that some languages actually forbids the name clashes + (it is the case of F* ). + *) +let mk_formatter (ctx : trans_ctx) (crate_name : string) + (variant_concatenate_type_name : bool) : formatter = + let int_name = fstar_int_name in + + (* Prepare a name. + * The first id elem is always the crate: if it is the local crate, + * we remove it. + * We also remove all the disambiguators, then convert everything to strings. + * **Rmk:** because we remove the disambiguators, there may be name collisions + * (which is ok, because we check for name collisions and fail if there is any). + *) + let get_name (name : name) : string list = + (* Rmk.: initially we only filtered the disambiguators equal to 0 *) + let name = Names.filter_disambiguators name in + match name with + | Ident crate :: name -> + let name = if crate = crate_name then name else Ident crate :: name in + let name = + List.map + (function + | Names.Ident s -> s + | Disambiguator d -> Names.Disambiguator.to_string d) + name + in + name + | _ -> + raise (Failure ("Unexpected name shape: " ^ Print.name_to_string name)) + in + let get_type_name = get_name in + let type_name_to_camel_case name = + let name = get_type_name name in + let name = List.map to_camel_case name in + String.concat "" name + in + let type_name_to_snake_case name = + let name = get_type_name name in + let name = List.map to_snake_case name in + String.concat "_" name + in + let type_name name = type_name_to_snake_case name ^ "_t" in + let field_name (def_name : name) (field_id : FieldId.id) + (field_name : string option) : string = + let def_name = type_name_to_snake_case def_name ^ "_" in + match field_name with + | Some field_name -> def_name ^ field_name + | None -> def_name ^ FieldId.to_string field_id + in + let variant_name (def_name : name) (variant : string) : string = + let variant = to_camel_case variant in + if variant_concatenate_type_name then + type_name_to_camel_case def_name ^ variant + else variant + in + let struct_constructor (basename : name) : string = + let tname = type_name basename in + "Mk" ^ tname + in + let get_fun_name = get_name in + let fun_name_to_snake_case (fname : fun_name) : string = + let fname = get_fun_name fname in + (* Converting to snake case should be a no-op, but it doesn't cost much *) + let fname = List.map to_snake_case fname in + (* Concatenate the elements *) + String.concat "_" fname + in + let global_name (name : global_name) : string = + (* Converting to snake case also lowercases the letters (in Rust, global + * names are written in capital letters). *) + let parts = List.map to_snake_case (get_name name) in + String.concat "_" parts + in + let fun_name (_fid : A.fun_id) (fname : fun_name) (num_rgs : int) + (rg : region_group_info option) (filter_info : bool * int) : string = + let fname = fun_name_to_snake_case fname in + (* Compute the suffix *) + let suffix = default_fun_suffix num_rgs rg filter_info in + (* Concatenate *) + fname ^ suffix + in + + let decreases_clause_name (_fid : A.FunDeclId.id) (fname : fun_name) : string + = + let fname = fun_name_to_snake_case fname in + (* Compute the suffix *) + let suffix = "_decreases" in + (* Concatenate *) + fname ^ suffix + in + + let var_basename (_varset : StringSet.t) (basename : string option) (ty : ty) + : string = + (* If there is a basename, we use it *) + match basename with + | Some basename -> + (* This should be a no-op *) + to_snake_case basename + | None -> ( + (* No basename: we use the first letter of the type *) + match ty with + | Adt (type_id, tys) -> ( + match type_id with + | Tuple -> + (* The "pair" case is frequent enough to have its special treatment *) + if List.length tys = 2 then "p" else "t" + | Assumed Result -> "r" + | Assumed Option -> "opt" + | Assumed Vec -> "v" + | Assumed State -> "st" + | AdtId adt_id -> + let def = + TypeDeclId.Map.find adt_id ctx.type_context.type_decls + in + (* We do the following: + * - compute the type name, and retrieve the last ident + * - convert this to snake case + * - take the first letter of every "letter group" + * Ex.: ["hashmap"; "HashMap"] ~~> "HashMap" -> "hash_map" -> "hm" + *) + (* Thename shouldn't be empty, and its last element should + * be an ident *) + let cl = List.nth def.name (List.length def.name - 1) in + let cl = to_snake_case (Names.as_ident cl) in + let cl = String.split_on_char '_' cl in + let cl = List.filter (fun s -> String.length s > 0) cl in + assert (List.length cl > 0); + let cl = List.map (fun s -> s.[0]) cl in + StringUtils.string_of_chars cl) + | TypeVar _ -> "x" (* lacking imagination here... *) + | Bool -> "b" + | Char -> "c" + | Integer _ -> "i" + | Str -> "s" + | Arrow _ -> "f" + | Array _ | Slice _ -> raise Unimplemented) + in + let type_var_basename (_varset : StringSet.t) (basename : string) : string = + (* This is *not* a no-op: type variables in Rust often start with + * a capital letter *) + to_snake_case basename + in + let append_index (basename : string) (i : int) : string = + basename ^ string_of_int i + in + + let extract_constant_value (fmt : F.formatter) (_inside : bool) + (cv : constant_value) : unit = + match cv with + | Scalar sv -> F.pp_print_string fmt (Z.to_string sv.V.value) + | Bool b -> + let b = if b then "true" else "false" in + F.pp_print_string fmt b + | Char c -> F.pp_print_string fmt ("'" ^ String.make 1 c ^ "'") + | String s -> + (* We need to replace all the line breaks *) + let s = + StringUtils.map + (fun c -> if c = '\n' then "\n" else String.make 1 c) + s + in + F.pp_print_string fmt ("\"" ^ s ^ "\"") + in + { + bool_name = "bool"; + char_name = "char"; + int_name; + str_name = "string"; + field_name; + variant_name; + struct_constructor; + type_name; + global_name; + fun_name; + decreases_clause_name; + var_basename; + type_var_basename; + append_index; + extract_constant_value; + extract_unop = fstar_extract_unop; + extract_binop = fstar_extract_binop; + } + +(** [inside] constrols whether we should add parentheses or not around type + application (if [true] we add parentheses). + *) +let rec extract_ty (ctx : extraction_ctx) (fmt : F.formatter) (inside : bool) + (ty : ty) : unit = + match ty with + | Adt (type_id, tys) -> ( + match type_id with + | Tuple -> + (* This is a bit annoying, but in F* [()] is not the unit type: + * we have to write [unit]... *) + if tys = [] then F.pp_print_string fmt "unit" + else ( + F.pp_print_string fmt "("; + Collections.List.iter_link + (fun () -> + F.pp_print_space fmt (); + F.pp_print_string fmt "&"; + F.pp_print_space fmt ()) + (extract_ty ctx fmt true) tys; + F.pp_print_string fmt ")") + | AdtId _ | Assumed _ -> + let print_paren = inside && tys <> [] in + if print_paren then F.pp_print_string fmt "("; + F.pp_print_string fmt (ctx_get_type type_id ctx); + if tys <> [] then F.pp_print_space fmt (); + Collections.List.iter_link (F.pp_print_space fmt) + (extract_ty ctx fmt true) tys; + if print_paren then F.pp_print_string fmt ")") + | TypeVar vid -> F.pp_print_string fmt (ctx_get_type_var vid ctx) + | Bool -> F.pp_print_string fmt ctx.fmt.bool_name + | Char -> F.pp_print_string fmt ctx.fmt.char_name + | Integer int_ty -> F.pp_print_string fmt (ctx.fmt.int_name int_ty) + | Str -> F.pp_print_string fmt ctx.fmt.str_name + | Arrow (arg_ty, ret_ty) -> + if inside then F.pp_print_string fmt "("; + extract_ty ctx fmt false arg_ty; + F.pp_print_space fmt (); + F.pp_print_string fmt "->"; + F.pp_print_space fmt (); + extract_ty ctx fmt false ret_ty; + if inside then F.pp_print_string fmt ")" + | Array _ | Slice _ -> raise Unimplemented + +(** Compute the names for all the top-level identifiers used in a type + definition (type name, variant names, field names, etc. but not type + parameters). + + We need to do this preemptively, beforce extracting any definition, + because of recursive definitions. + *) +let extract_type_decl_register_names (ctx : extraction_ctx) (def : type_decl) : + extraction_ctx = + (* Compute and register the type def name *) + let ctx = ctx_add_type_decl def ctx in + (* Compute and register: + * - the variant names, if this is an enumeration + * - the field names, if this is a structure + *) + let ctx = + match def.kind with + | Struct fields -> + (* Add the fields *) + let ctx = + fst + (ctx_add_fields def (FieldId.mapi (fun id f -> (id, f)) fields) ctx) + in + (* Add the constructor name *) + fst (ctx_add_struct def ctx) + | Enum variants -> + fst + (ctx_add_variants def + (VariantId.mapi (fun id v -> (id, v)) variants) + ctx) + | Opaque -> + (* Nothing to do *) + ctx + in + (* Return *) + ctx + +let extract_type_decl_struct_body (ctx : extraction_ctx) (fmt : F.formatter) + (def : type_decl) (fields : field list) : unit = + (* We want to generate a definition which looks like this: + {[ + type t = { x : int; y : bool; } + ]} + + If there isn't enough space on one line: + {[ + type t = + { + x : int; y : bool; + } + ]} + + And if there is even less space: + {[ + type t = + { + x : int; + y : bool; + } + ]} + + Also, in case there are no fields, we need to define the type as [unit] + ([type t = {}] doesn't work in F* ). + *) + (* Note that we already printed: [type t =] *) + if fields = [] then ( + F.pp_print_space fmt (); + F.pp_print_string fmt "unit") + else ( + F.pp_print_space fmt (); + F.pp_print_string fmt "{"; + F.pp_print_break fmt 1 ctx.indent_incr; + (* The body itself *) + F.pp_open_hvbox fmt 0; + (* Print the fields *) + let print_field (field_id : FieldId.id) (f : field) : unit = + let field_name = ctx_get_field (AdtId def.def_id) field_id ctx in + F.pp_open_box fmt ctx.indent_incr; + F.pp_print_string fmt field_name; + F.pp_print_space fmt (); + F.pp_print_string fmt ":"; + F.pp_print_space fmt (); + extract_ty ctx fmt false f.field_ty; + F.pp_print_string fmt ";"; + F.pp_close_box fmt () + in + let fields = FieldId.mapi (fun fid f -> (fid, f)) fields in + Collections.List.iter_link (F.pp_print_space fmt) + (fun (fid, f) -> print_field fid f) + fields; + (* Close *) + F.pp_close_box fmt (); + F.pp_print_space fmt (); + F.pp_print_string fmt "}") + +let extract_type_decl_enum_body (ctx : extraction_ctx) (fmt : F.formatter) + (def : type_decl) (def_name : string) (type_params : string list) + (variants : variant list) : unit = + (* We want to generate a definition which looks like this: + {[ + type list a = | Cons : a -> list a -> list a | Nil : list a + ]} + + If there isn't enough space on one line: + {[ + type s = + | Cons : a -> list a -> list a + | Nil : list a + ]} + + And if we need to write the type of a variant on several lines: + {[ + type s = + | Cons : + a -> + list a -> + list a + | Nil : list a + ]} + + Finally, it is possible to give names to the variant fields in Rust. + In this situation, we generate a definition like this: + {[ + type s = + | Cons : hd:a -> tl:list a -> list a + | Nil : list a + ]} + + Note that we already printed: [type s =] + *) + (* Print the variants *) + let print_variant (variant_id : VariantId.id) (variant : variant) : unit = + let variant_name = ctx_get_variant (AdtId def.def_id) variant_id ctx in + F.pp_print_space fmt (); + F.pp_open_hvbox fmt ctx.indent_incr; + (* variant box *) + (* [| Cons :] + * Note that we really don't want any break above so we print everything + * at once. *) + F.pp_print_string fmt ("| " ^ variant_name ^ " :"); + F.pp_print_space fmt (); + let print_field (fid : FieldId.id) (f : field) (ctx : extraction_ctx) : + extraction_ctx = + (* Open the field box *) + F.pp_open_box fmt ctx.indent_incr; + (* Print the field names + * [ x :] + * Note that when printing fields, we register the field names as + * *variables*: they don't need to be unique at the top level. *) + let ctx = + match f.field_name with + | None -> ctx + | Some field_name -> + let var_id = VarId.of_int (FieldId.to_int fid) in + let field_name = + ctx.fmt.var_basename ctx.names_map.names_set (Some field_name) + f.field_ty + in + let ctx, field_name = ctx_add_var field_name var_id ctx in + F.pp_print_string fmt (field_name ^ " :"); + F.pp_print_space fmt (); + ctx + in + (* Print the field type *) + extract_ty ctx fmt false f.field_ty; + (* Print the arrow [->]*) + F.pp_print_space fmt (); + F.pp_print_string fmt "->"; + (* Close the field box *) + F.pp_close_box fmt (); + F.pp_print_space fmt (); + (* Return *) + ctx + in + (* Print the fields *) + let fields = FieldId.mapi (fun fid f -> (fid, f)) variant.fields in + let _ = + List.fold_left (fun ctx (fid, f) -> print_field fid f ctx) ctx fields + in + (* Print the final type *) + F.pp_open_hovbox fmt 0; + F.pp_print_string fmt def_name; + List.iter + (fun type_param -> + F.pp_print_space fmt (); + F.pp_print_string fmt type_param) + type_params; + F.pp_close_box fmt (); + (* Close the variant box *) + F.pp_close_box fmt () + in + (* Print the variants *) + let variants = VariantId.mapi (fun vid v -> (vid, v)) variants in + List.iter (fun (vid, v) -> print_variant vid v) variants + +(** Extract a type declaration. + + Note that all the names used for extraction should already have been + registered. + *) +let extract_type_decl (ctx : extraction_ctx) (fmt : F.formatter) + (qualif : type_decl_qualif) (def : type_decl) : unit = + (* Retrieve the definition name *) + let def_name = ctx_get_local_type def.def_id ctx in + (* Add the type params - note that we need those bindings only for the + * body translation (they are not top-level) *) + let ctx_body, type_params = ctx_add_type_params def.type_params ctx in + (* Add a break before *) + F.pp_print_break fmt 0 0; + (* Print a comment to link the extracted type to its original rust definition *) + F.pp_print_string fmt ("(** [" ^ Print.name_to_string def.name ^ "] *)"); + F.pp_print_space fmt (); + (* Open a box for the definition, so that whenever possible it gets printed on + * one line *) + F.pp_open_hvbox fmt 0; + (* Open a box for "type TYPE_NAME (TYPE_PARAMS) =" *) + F.pp_open_hovbox fmt ctx.indent_incr; + (* > "type TYPE_NAME" *) + let extract_body, qualif = + match qualif with + | Type -> (true, "type") + | And -> (true, "and") + | AssumeType -> (false, "assume type") + | TypeVal -> (false, "val") + in + F.pp_print_string fmt (qualif ^ " " ^ def_name); + (* Print the type parameters *) + if def.type_params <> [] then ( + F.pp_print_space fmt (); + F.pp_print_string fmt "("; + List.iter + (fun (p : type_var) -> + let pname = ctx_get_type_var p.index ctx_body in + F.pp_print_string fmt pname; + F.pp_print_space fmt ()) + def.type_params; + F.pp_print_string fmt ":"; + F.pp_print_space fmt (); + F.pp_print_string fmt "Type0)"); + (* Print the "=" if we extract the body*) + if extract_body then ( + F.pp_print_space fmt (); + F.pp_print_string fmt "=") + else ( + (* Otherwise print ": Type0" *) + F.pp_print_space fmt (); + F.pp_print_string fmt ":"; + F.pp_print_space fmt (); + F.pp_print_string fmt "Type0"); + (* Close the box for "type TYPE_NAME (TYPE_PARAMS) =" *) + F.pp_close_box fmt (); + (if extract_body then + match def.kind with + | Struct fields -> extract_type_decl_struct_body ctx_body fmt def fields + | Enum variants -> + extract_type_decl_enum_body ctx_body fmt def def_name type_params + variants + | Opaque -> raise (Failure "Unreachable")); + (* Close the box for the definition *) + F.pp_close_box fmt (); + (* Add breaks to insert new lines between definitions *) + F.pp_print_break fmt 0 0 + +(** Extract the state type declaration. *) +let extract_state_type (fmt : F.formatter) (ctx : extraction_ctx) + (qualif : type_decl_qualif) : unit = + (* Add a break before *) + F.pp_print_break fmt 0 0; + (* Print a comment *) + F.pp_print_string fmt "(** The state type used in the state-error monad *)"; + F.pp_print_space fmt (); + (* Open a box for the definition, so that whenever possible it gets printed on + * one line *) + F.pp_open_hvbox fmt 0; + (* Retrieve the name *) + let state_name = ctx_get_assumed_type State ctx in + (* The qualif should be [AssumeType] or [TypeVal] *) + (match qualif with + | Type | And -> raise (Failure "Unexpected") + | AssumeType -> + F.pp_print_string fmt "assume"; + F.pp_print_space fmt (); + F.pp_print_string fmt "type"; + F.pp_print_space fmt (); + F.pp_print_string fmt state_name; + F.pp_print_space fmt (); + F.pp_print_string fmt ":"; + F.pp_print_space fmt (); + F.pp_print_string fmt "Type0" + | TypeVal -> + F.pp_print_string fmt "val"; + F.pp_print_space fmt (); + F.pp_print_string fmt state_name; + F.pp_print_space fmt (); + F.pp_print_string fmt ":"; + F.pp_print_space fmt (); + F.pp_print_string fmt "Type0"); + (* Close the box for the definition *) + F.pp_close_box fmt (); + (* Add breaks to insert new lines between definitions *) + F.pp_print_break fmt 0 0 + +(** Compute the names for all the pure functions generated from a rust function + (forward function and backward functions). + *) +let extract_fun_decl_register_names (ctx : extraction_ctx) (keep_fwd : bool) + (has_decreases_clause : bool) (def : pure_fun_translation) : extraction_ctx + = + let fwd, back_ls = def in + (* Register the decrease clause, if necessary *) + let ctx = + if has_decreases_clause then ctx_add_decrases_clause fwd ctx else ctx + in + (* Register the forward function name *) + let ctx = ctx_add_fun_decl (keep_fwd, def) fwd ctx in + (* Register the backward functions' names *) + let ctx = + List.fold_left + (fun ctx back -> ctx_add_fun_decl (keep_fwd, def) back ctx) + ctx back_ls + in + (* Return *) + ctx + +(** Simply add the global name to the context. *) +let extract_global_decl_register_names (ctx : extraction_ctx) + (def : A.global_decl) : extraction_ctx = + ctx_add_global_decl_and_body def ctx + +(** The following function factorizes the extraction of ADT values. + + Note that patterns can introduce new variables: we thus return an extraction + context updated with new bindings. + + TODO: we don't need something very generic anymore + *) +let extract_adt_g_value + (extract_value : extraction_ctx -> bool -> 'v -> extraction_ctx) + (fmt : F.formatter) (ctx : extraction_ctx) (inside : bool) + (variant_id : VariantId.id option) (field_values : 'v list) (ty : ty) : + extraction_ctx = + match ty with + | Adt (Tuple, _) -> + (* Tuple *) + F.pp_print_string fmt "("; + let ctx = + Collections.List.fold_left_link + (fun () -> + F.pp_print_string fmt ","; + F.pp_print_space fmt ()) + (fun ctx v -> extract_value ctx false v) + ctx field_values + in + F.pp_print_string fmt ")"; + ctx + | Adt (adt_id, _) -> + (* "Regular" ADT *) + (* We print something of the form: [Cons field0 ... fieldn]. + * We could update the code to print something of the form: + * [{ field0=...; ...; fieldn=...; }] in case of structures. + *) + let cons = + match variant_id with + | Some vid -> ctx_get_variant adt_id vid ctx + | None -> ctx_get_struct adt_id ctx + in + if inside && field_values <> [] then F.pp_print_string fmt "("; + F.pp_print_string fmt cons; + let ctx = + Collections.List.fold_left + (fun ctx v -> + F.pp_print_space fmt (); + extract_value ctx true v) + ctx field_values + in + if inside && field_values <> [] then F.pp_print_string fmt ")"; + ctx + | _ -> raise (Failure "Inconsistent typed value") + +(* Extract globals in the same way as variables *) +let extract_global (ctx : extraction_ctx) (fmt : F.formatter) + (id : A.GlobalDeclId.id) : unit = + F.pp_print_string fmt (ctx_get_global id ctx) + +(** [inside]: see [extract_ty]. + + As a pattern can introduce new variables, we return an extraction context + updated with new bindings. + *) +let rec extract_typed_pattern (ctx : extraction_ctx) (fmt : F.formatter) + (inside : bool) (v : typed_pattern) : extraction_ctx = + match v.value with + | PatConcrete cv -> + ctx.fmt.extract_constant_value fmt inside cv; + ctx + | PatVar (v, _) -> + let vname = + ctx.fmt.var_basename ctx.names_map.names_set v.basename v.ty + in + let ctx, vname = ctx_add_var vname v.id ctx in + F.pp_print_string fmt vname; + ctx + | PatDummy -> + F.pp_print_string fmt "_"; + ctx + | PatAdt av -> + let extract_value ctx inside v = extract_typed_pattern ctx fmt inside v in + extract_adt_g_value extract_value fmt ctx inside av.variant_id + av.field_values v.ty + +(** [inside]: controls the introduction of parentheses. See [extract_ty] + + TODO: replace the formatting boolean [inside] with something more general? + Also, it seems we don't really use it... + Cases to consider: + - right-expression in a let: [let x = re in _] (never parentheses?) + - next expression in a let: [let x = _ in next_e] (never parentheses?) + - application argument: [f (exp)] + - match/if scrutinee: [if exp then _ else _]/[match exp | _ -> _] + *) +let rec extract_texpression (ctx : extraction_ctx) (fmt : F.formatter) + (inside : bool) (e : texpression) : unit = + match e.e with + | Var var_id -> + let var_name = ctx_get_var var_id ctx in + F.pp_print_string fmt var_name + | Const cv -> ctx.fmt.extract_constant_value fmt inside cv + | App _ -> + let app, args = destruct_apps e in + extract_App ctx fmt inside app args + | Abs _ -> + let xl, e = destruct_abs_list e in + extract_Abs ctx fmt inside xl e + | Qualif _ -> + (* We use the app case *) + extract_App ctx fmt inside e [] + | Let (monadic, lv, re, next_e) -> + extract_Let ctx fmt inside monadic lv re next_e + | Switch (scrut, body) -> extract_Switch ctx fmt inside scrut body + | Meta (_, e) -> extract_texpression ctx fmt inside e + +(* Extract an application *or* a top-level qualif (function extraction has + * to handle top-level qualifiers, so it seemed more natural to merge the + * two cases) *) +and extract_App (ctx : extraction_ctx) (fmt : F.formatter) (inside : bool) + (app : texpression) (args : texpression list) : unit = + (* We don't do the same thing if the app is a top-level identifier (function, + * ADT constructor...) or a "regular" expression *) + match app.e with + | Qualif qualif -> ( + (* Top-level qualifier *) + match qualif.id with + | Func fun_id -> + extract_function_call ctx fmt inside fun_id qualif.type_args args + | Global global_id -> extract_global ctx fmt global_id + | AdtCons adt_cons_id -> + extract_adt_cons ctx fmt inside adt_cons_id qualif.type_args args + | Proj proj -> + extract_field_projector ctx fmt inside app proj qualif.type_args args) + | _ -> + (* "Regular" expression *) + (* Open parentheses *) + if inside then F.pp_print_string fmt "("; + (* Open a box for the application *) + F.pp_open_hovbox fmt ctx.indent_incr; + (* Print the app expression *) + let app_inside = (inside && args = []) || args <> [] in + extract_texpression ctx fmt app_inside app; + (* Print the arguments *) + List.iter + (fun ve -> + F.pp_print_space fmt (); + extract_texpression ctx fmt true ve) + args; + (* Close the box for the application *) + F.pp_close_box fmt (); + (* Close parentheses *) + if inside then F.pp_print_string fmt ")" + +(** Subcase of the app case: function call *) +and extract_function_call (ctx : extraction_ctx) (fmt : F.formatter) + (inside : bool) (fid : fun_id) (type_args : ty list) + (args : texpression list) : unit = + match (fid, args) with + | Unop unop, [ arg ] -> + (* A unop can have *at most* one argument (the result can't be a function!). + * Note that the way we generate the translation, we shouldn't get the + * case where we have no argument (all functions are fully instantiated, + * and no AST transformation introduces partial calls). *) + ctx.fmt.extract_unop (extract_texpression ctx fmt) fmt inside unop arg + | Binop (binop, int_ty), [ arg0; arg1 ] -> + (* Number of arguments: similar to unop *) + ctx.fmt.extract_binop + (extract_texpression ctx fmt) + fmt inside binop int_ty arg0 arg1 + | Regular (fun_id, rg_id), _ -> + if inside then F.pp_print_string fmt "("; + (* Open a box for the function call *) + F.pp_open_hovbox fmt ctx.indent_incr; + (* Print the function name *) + let fun_name = ctx_get_function fun_id rg_id ctx in + F.pp_print_string fmt fun_name; + (* Print the type parameters *) + List.iter + (fun ty -> + F.pp_print_space fmt (); + extract_ty ctx fmt true ty) + type_args; + (* Print the arguments *) + List.iter + (fun ve -> + F.pp_print_space fmt (); + extract_texpression ctx fmt true ve) + args; + (* Close the box for the function call *) + F.pp_close_box fmt (); + (* Return *) + if inside then F.pp_print_string fmt ")" + | _ -> + raise + (Failure + ("Unreachable:\n" ^ "Function: " ^ show_fun_id fid + ^ ",\nNumber of arguments: " + ^ string_of_int (List.length args) + ^ ",\nArguments: " + ^ String.concat " " (List.map show_texpression args))) + +(** Subcase of the app case: ADT constructor *) +and extract_adt_cons (ctx : extraction_ctx) (fmt : F.formatter) (inside : bool) + (adt_cons : adt_cons_id) (type_args : ty list) (args : texpression list) : + unit = + match adt_cons.adt_id with + | Tuple -> + (* Tuple *) + (* For now, we only support fully applied tuple constructors *) + assert (List.length type_args = List.length args); + F.pp_print_string fmt "("; + Collections.List.iter_link + (fun () -> + F.pp_print_string fmt ","; + F.pp_print_space fmt ()) + (fun v -> extract_texpression ctx fmt false v) + args; + F.pp_print_string fmt ")" + | _ -> + (* "Regular" ADT *) + (* We print something of the form: [Cons field0 ... fieldn]. + * We could update the code to print something of the form: + * [{ field0=...; ...; fieldn=...; }] in case of fully + * applied structure constructors. + *) + let cons = + match adt_cons.variant_id with + | Some vid -> ctx_get_variant adt_cons.adt_id vid ctx + | None -> ctx_get_struct adt_cons.adt_id ctx + in + let use_parentheses = inside && args <> [] in + if use_parentheses then F.pp_print_string fmt "("; + F.pp_print_string fmt cons; + Collections.List.iter + (fun v -> + F.pp_print_space fmt (); + extract_texpression ctx fmt true v) + args; + if use_parentheses then F.pp_print_string fmt ")" + +(** Subcase of the app case: ADT field projector. *) +and extract_field_projector (ctx : extraction_ctx) (fmt : F.formatter) + (inside : bool) (original_app : texpression) (proj : projection) + (_proj_type_params : ty list) (args : texpression list) : unit = + (* We isolate the first argument (if there is), in order to pretty print the + * projection ([x.field] instead of [MkAdt?.field x] *) + match args with + | [ arg ] -> + (* Exactly one argument: pretty-print *) + let field_name = ctx_get_field proj.adt_id proj.field_id ctx in + (* Open a box *) + F.pp_open_hovbox fmt ctx.indent_incr; + (* Extract the expression *) + extract_texpression ctx fmt true arg; + (* We allow to break where the "." appears *) + F.pp_print_break fmt 0 0; + F.pp_print_string fmt "."; + F.pp_print_string fmt field_name; + (* Close the box *) + F.pp_close_box fmt () + | arg :: args -> + (* Call extract_App again, but in such a way that the first argument is + * isolated *) + extract_App ctx fmt inside (mk_app original_app arg) args + | [] -> + (* No argument: shouldn't happen *) + raise (Failure "Unreachable") + +and extract_Abs (ctx : extraction_ctx) (fmt : F.formatter) (inside : bool) + (xl : typed_pattern list) (e : texpression) : unit = + (* Open a box for the abs expression *) + F.pp_open_hovbox fmt ctx.indent_incr; + (* Open parentheses *) + if inside then F.pp_print_string fmt "("; + (* Print the lambda - note that there should always be at least one variable *) + assert (xl <> []); + F.pp_print_string fmt "fun"; + let ctx = + List.fold_left + (fun ctx x -> + F.pp_print_space fmt (); + extract_typed_pattern ctx fmt true x) + ctx xl + in + F.pp_print_space fmt (); + F.pp_print_string fmt "->"; + F.pp_print_space fmt (); + (* Print the body *) + extract_texpression ctx fmt false e; + (* Close parentheses *) + if inside then F.pp_print_string fmt ")"; + (* Close the box for the abs expression *) + F.pp_close_box fmt () + +and extract_Let (ctx : extraction_ctx) (fmt : F.formatter) (inside : bool) + (monadic : bool) (lv : typed_pattern) (re : texpression) + (next_e : texpression) : unit = + (* Open a box for the whole expression *) + F.pp_open_hvbox fmt 0; + (* Open parentheses *) + if inside then F.pp_print_string fmt "("; + (* Open a box for the let-binding *) + F.pp_open_hovbox fmt ctx.indent_incr; + let ctx = + if monadic then ( + (* Note that in F*, the left value of a monadic let-binding can only be + * a variable *) + let ctx = extract_typed_pattern ctx fmt true lv in + F.pp_print_space fmt (); + F.pp_print_string fmt "<--"; + F.pp_print_space fmt (); + extract_texpression ctx fmt false re; + F.pp_print_string fmt ";"; + ctx) + else ( + F.pp_print_string fmt "let"; + F.pp_print_space fmt (); + let ctx = extract_typed_pattern ctx fmt true lv in + F.pp_print_space fmt (); + F.pp_print_string fmt "="; + F.pp_print_space fmt (); + extract_texpression ctx fmt false re; + F.pp_print_space fmt (); + F.pp_print_string fmt "in"; + ctx) + in + (* Close the box for the let-binding *) + F.pp_close_box fmt (); + (* Print the next expression *) + F.pp_print_space fmt (); + extract_texpression ctx fmt false next_e; + (* Close parentheses *) + if inside then F.pp_print_string fmt ")"; + (* Close the box for the whole expression *) + F.pp_close_box fmt () + +and extract_Switch (ctx : extraction_ctx) (fmt : F.formatter) (inside : bool) + (scrut : texpression) (body : switch_body) : unit = + (* Open a box for the whole expression *) + F.pp_open_hvbox fmt 0; + (* Open parentheses *) + if inside then F.pp_print_string fmt "("; + (* Extract the switch *) + (match body with + | If (e_then, e_else) -> + (* Open a box for the [if] *) + F.pp_open_hovbox fmt ctx.indent_incr; + F.pp_print_string fmt "if"; + F.pp_print_space fmt (); + let scrut_inside = PureUtils.let_group_requires_parentheses scrut in + extract_texpression ctx fmt scrut_inside scrut; + (* Close the box for the [if] *) + F.pp_close_box fmt (); + (* Extract the branches *) + let extract_branch (is_then : bool) (e_branch : texpression) : unit = + F.pp_print_space fmt (); + (* Open a box for the then/else+branch *) + F.pp_open_hovbox fmt ctx.indent_incr; + let then_or_else = if is_then then "then" else "else" in + F.pp_print_string fmt then_or_else; + F.pp_print_space fmt (); + (* Open a box for the branch *) + F.pp_open_hovbox fmt ctx.indent_incr; + (* Print the [begin] if necessary *) + let parenth = PureUtils.let_group_requires_parentheses e_branch in + if parenth then ( + F.pp_print_string fmt "begin"; + F.pp_print_space fmt ()); + (* Print the branch expression *) + extract_texpression ctx fmt false e_branch; + (* Close the [begin ... end ] *) + if parenth then ( + F.pp_print_space fmt (); + F.pp_print_string fmt "end"); + (* Close the box for the branch *) + F.pp_close_box fmt (); + (* Close the box for the then/else+branch *) + F.pp_close_box fmt () + in + + extract_branch true e_then; + extract_branch false e_else + | Match branches -> + (* Open a box for the [match ... with] *) + F.pp_open_hovbox fmt ctx.indent_incr; + (* Print the [match ... with] *) + F.pp_print_string fmt "begin match"; + F.pp_print_space fmt (); + let scrut_inside = PureUtils.let_group_requires_parentheses scrut in + extract_texpression ctx fmt scrut_inside scrut; + F.pp_print_space fmt (); + F.pp_print_string fmt "with"; + (* Close the box for the [match ... with] *) + F.pp_close_box fmt (); + + (* Extract the branches *) + let extract_branch (br : match_branch) : unit = + F.pp_print_space fmt (); + (* Open a box for the pattern+branch *) + F.pp_open_hovbox fmt ctx.indent_incr; + F.pp_print_string fmt "|"; + (* Print the pattern *) + F.pp_print_space fmt (); + let ctx = extract_typed_pattern ctx fmt false br.pat in + F.pp_print_space fmt (); + F.pp_print_string fmt "->"; + F.pp_print_space fmt (); + (* Open a box for the branch *) + F.pp_open_hovbox fmt ctx.indent_incr; + (* Print the branch itself *) + extract_texpression ctx fmt false br.branch; + (* Close the box for the branch *) + F.pp_close_box fmt (); + (* Close the box for the pattern+branch *) + F.pp_close_box fmt () + in + + List.iter extract_branch branches; + + (* End the match *) + F.pp_print_space fmt (); + F.pp_print_string fmt "end"); + (* Close parentheses *) + if inside then F.pp_print_string fmt ")"; + (* Close the box for the whole expression *) + F.pp_close_box fmt () + +(** A small utility to print the parameters of a function signature. + + We return two contexts: + - the context augmented with bindings for the type parameters + - the previous context augmented with bindings for the input values + *) +let extract_fun_parameters (ctx : extraction_ctx) (fmt : F.formatter) + (def : fun_decl) : extraction_ctx * extraction_ctx = + (* Add the type parameters - note that we need those bindings only for the + * body translation (they are not top-level) *) + let ctx, _ = ctx_add_type_params def.signature.type_params ctx in + (* Print the parameters - rk.: we should have filtered the functions + * with no input parameters *) + (* The type parameters *) + if def.signature.type_params <> [] then ( + (* Open a box for the type parameters *) + F.pp_open_hovbox fmt 0; + F.pp_print_string fmt "("; + List.iter + (fun (p : type_var) -> + let pname = ctx_get_type_var p.index ctx in + F.pp_print_string fmt pname; + F.pp_print_space fmt ()) + def.signature.type_params; + F.pp_print_string fmt ":"; + F.pp_print_space fmt (); + F.pp_print_string fmt "Type0)"; + (* Close the box for the type parameters *) + F.pp_close_box fmt (); + F.pp_print_space fmt ()); + (* The input parameters - note that doing this adds bindings to the context *) + let ctx_body = + match def.body with + | None -> ctx + | Some body -> + List.fold_left + (fun ctx (lv : typed_pattern) -> + (* Open a box for the input parameter *) + F.pp_open_hovbox fmt 0; + F.pp_print_string fmt "("; + let ctx = extract_typed_pattern ctx fmt false lv in + F.pp_print_space fmt (); + F.pp_print_string fmt ":"; + F.pp_print_space fmt (); + extract_ty ctx fmt false lv.ty; + F.pp_print_string fmt ")"; + (* Close the box for the input parameters *) + F.pp_close_box fmt (); + F.pp_print_space fmt (); + ctx) + ctx body.inputs_lvs + in + (ctx, ctx_body) + +(** A small utility to print the types of the input parameters in the form: + [u32 -> list u32 -> ...] + (we don't print the return type of the function) + + This is used for opaque function declarations, in particular. + *) +let extract_fun_input_parameters_types (ctx : extraction_ctx) + (fmt : F.formatter) (def : fun_decl) : unit = + let extract_param (ty : ty) : unit = + let inside = false in + extract_ty ctx fmt inside ty; + F.pp_print_space fmt (); + F.pp_print_string fmt "->"; + F.pp_print_space fmt () + in + List.iter extract_param def.signature.inputs + +(** Extract a decrease clause function template body. + + In order to help the user, we can generate a template for the functions + required by the decreases clauses. We simply generate definitions of + the following form in a separate file: + {[ + let f_decrease (t : Type0) (x : t) : nat = admit() + ]} + + Where the translated functions for [f] look like this: + {[ + let f_fwd (t : Type0) (x : t) : Tot ... (decreases (f_decrease t x)) = ... + ]} + *) +let extract_template_decreases_clause (ctx : extraction_ctx) (fmt : F.formatter) + (def : fun_decl) : unit = + (* Retrieve the function name *) + let def_name = ctx_get_decreases_clause def.def_id ctx in + (* Add a break before *) + F.pp_print_break fmt 0 0; + (* Print a comment to link the extracted type to its original rust definition *) + F.pp_print_string fmt + ("(** [" ^ Print.fun_name_to_string def.basename ^ "]: decreases clause *)"); + F.pp_print_space fmt (); + (* Open a box for the definition, so that whenever possible it gets printed on + * one line *) + F.pp_open_hvbox fmt 0; + (* Add the [unfold] keyword *) + F.pp_print_string fmt "unfold"; + F.pp_print_space fmt (); + (* Open a box for "let FUN_NAME (PARAMS) : EFFECT = admit()" *) + F.pp_open_hvbox fmt ctx.indent_incr; + (* Open a box for "let FUN_NAME (PARAMS) : EFFECT =" *) + F.pp_open_hovbox fmt ctx.indent_incr; + (* > "let FUN_NAME" *) + F.pp_print_string fmt ("let " ^ def_name); + F.pp_print_space fmt (); + (* Extract the parameters *) + let _, _ = extract_fun_parameters ctx fmt def in + F.pp_print_string fmt ":"; + (* Print the signature *) + F.pp_print_space fmt (); + F.pp_print_string fmt "nat"; + (* Print the "=" *) + F.pp_print_space fmt (); + F.pp_print_string fmt "="; + (* Close the box for "let FUN_NAME (PARAMS) : EFFECT =" *) + F.pp_close_box fmt (); + F.pp_print_space fmt (); + (* Print the "admit ()" *) + F.pp_print_string fmt "admit ()"; + (* Close the box for "let FUN_NAME (PARAMS) : EFFECT = admit()" *) + F.pp_close_box fmt (); + (* Close the box for the whole definition *) + F.pp_close_box fmt (); + (* Add breaks to insert new lines between definitions *) + F.pp_print_break fmt 0 0 + +(** Extract a function declaration. + + Note that all the names used for extraction should already have been + registered. + + We take the definition of the forward translation as parameter (which is + equal to the definition to extract, if we extract a forward function) because + it is useful for the decrease clause. + *) +let extract_fun_decl (ctx : extraction_ctx) (fmt : F.formatter) + (qualif : fun_decl_qualif) (has_decreases_clause : bool) (def : fun_decl) : + unit = + assert (not def.is_global_decl_body); + (* Retrieve the function name *) + let def_name = ctx_get_local_function def.def_id def.back_id ctx in + (* (* Add the type parameters - note that we need those bindings only for the + * body translation (they are not top-level) *) + let ctx, _ = ctx_add_type_params def.signature.type_params ctx in *) + (* Add a break before *) + F.pp_print_break fmt 0 0; + (* Print a comment to link the extracted type to its original rust definition *) + F.pp_print_string fmt + ("(** [" ^ Print.fun_name_to_string def.basename ^ "] *)"); + F.pp_print_space fmt (); + (* Open a box for the definition, so that whenever possible it gets printed on + * one line *) + F.pp_open_hvbox fmt ctx.indent_incr; + (* Open a box for "let FUN_NAME (PARAMS) : EFFECT =" *) + F.pp_open_hovbox fmt ctx.indent_incr; + (* > "let FUN_NAME" *) + let is_opaque = Option.is_none def.body in + let qualif = fun_decl_qualif_keyword qualif in + F.pp_print_string fmt (qualif ^ " " ^ def_name); + F.pp_print_space fmt (); + (* Open a box for "(PARAMS) : EFFECT =" *) + F.pp_open_hvbox fmt 0; + (* Open a box for "(PARAMS)" *) + F.pp_open_hovbox fmt 0; + let ctx, ctx_body = extract_fun_parameters ctx fmt def in + (* Close the box for "(PARAMS)" *) + F.pp_close_box fmt (); + (* Print the return type - note that we have to be careful when + * printing the input values for the decrease clause, because + * it introduces bindings in the context... We thus "forget" + * the bindings we introduced above. + * TODO: figure out a cleaner way *) + let _ = + F.pp_print_string fmt ":"; + F.pp_print_space fmt (); + (* Open a box for the EFFECT *) + F.pp_open_hvbox fmt 0; + (* Open a box for the return type *) + F.pp_open_hovbox fmt ctx.indent_incr; + (* Print the return type *) + (* For opaque definitions, as we don't have named parameters under the hand, + * we don't print parameters in the form [(x : a) (y : b) ...] above, + * but wait until here to print the types: [a -> b -> ...]. *) + if is_opaque then extract_fun_input_parameters_types ctx fmt def; + (* [Tot] *) + if has_decreases_clause then ( + F.pp_print_string fmt "Tot"; + F.pp_print_space fmt ()); + extract_ty ctx fmt has_decreases_clause def.signature.output; + (* Close the box for the return type *) + F.pp_close_box fmt (); + (* Print the decrease clause - rk.: a function with a decreases clause + * is necessarily a transparent function *) + if has_decreases_clause then ( + F.pp_print_space fmt (); + (* Open a box for the decrease clause *) + F.pp_open_hovbox fmt 0; + (* *) + F.pp_print_string fmt "(decreases"; + F.pp_print_space fmt (); + F.pp_print_string fmt "("; + (* The name of the decrease clause *) + let decr_name = ctx_get_decreases_clause def.def_id ctx in + F.pp_print_string fmt decr_name; + (* Print the type parameters *) + List.iter + (fun (p : type_var) -> + let pname = ctx_get_type_var p.index ctx in + F.pp_print_space fmt (); + F.pp_print_string fmt pname) + def.signature.type_params; + (* Print the input values: we have to be careful here to print + * only the input values which are in common with the *forward* + * function (the additional input values "given back" to the + * backward functions have no influence on termination: we thus + * share the decrease clauses between the forward and the backward + * functions). + *) + let inputs_lvs = + let all_inputs = (Option.get def.body).inputs_lvs in + (* We have to count: + * - the forward inputs + * - the state + *) + let num_fwd_inputs = def.signature.info.num_fwd_inputs in + let num_fwd_inputs = + if def.signature.info.effect_info.input_state then 1 + num_fwd_inputs + else num_fwd_inputs + in + Collections.List.prefix num_fwd_inputs all_inputs + in + let _ = + List.fold_left + (fun ctx (lv : typed_pattern) -> + F.pp_print_space fmt (); + let ctx = extract_typed_pattern ctx fmt false lv in + ctx) + ctx inputs_lvs + in + F.pp_print_string fmt "))"; + (* Close the box for the decrease clause *) + F.pp_close_box fmt ()); + (* Close the box for the EFFECT *) + F.pp_close_box fmt () + in + (* Print the "=" *) + if not is_opaque then ( + F.pp_print_space fmt (); + F.pp_print_string fmt "="); + (* Close the box for "(PARAMS) : EFFECT =" *) + F.pp_close_box fmt (); + (* Close the box for "let FUN_NAME (PARAMS) : EFFECT =" *) + F.pp_close_box fmt (); + if not is_opaque then ( + F.pp_print_space fmt (); + (* Open a box for the body *) + F.pp_open_hvbox fmt 0; + (* Extract the body *) + let _ = extract_texpression ctx_body fmt false (Option.get def.body).body in + (* Close the box for the body *) + F.pp_close_box fmt ()); + (* Close the box for the definition *) + F.pp_close_box fmt (); + (* Add breaks to insert new lines between definitions *) + F.pp_print_break fmt 0 0 + +(** Extract a global declaration body of the shape "QUALIF NAME : TYPE = BODY" with a custom body extractor *) +let extract_global_decl_body (ctx : extraction_ctx) (fmt : F.formatter) + (qualif : fun_decl_qualif) (name : string) (ty : ty) + (extract_body : (F.formatter -> unit) Option.t) : unit = + let is_opaque = Option.is_none extract_body in + + (* Open the definition box (depth=0) *) + F.pp_open_hvbox fmt ctx.indent_incr; + + (* Open "QUALIF NAME : TYPE =" box (depth=1) *) + F.pp_open_hovbox fmt ctx.indent_incr; + (* Print "QUALIF NAME " *) + F.pp_print_string fmt (fun_decl_qualif_keyword qualif ^ " " ^ name); + F.pp_print_space fmt (); + + (* Open ": TYPE =" box (depth=2) *) + F.pp_open_hvbox fmt 0; + (* Print ": " *) + F.pp_print_string fmt ":"; + F.pp_print_space fmt (); + + (* Open "TYPE" box (depth=3) *) + F.pp_open_hovbox fmt ctx.indent_incr; + (* Print "TYPE" *) + extract_ty ctx fmt false ty; + (* Close "TYPE" box (depth=3) *) + F.pp_close_box fmt (); + + if not is_opaque then ( + (* Print " =" *) + F.pp_print_space fmt (); + F.pp_print_string fmt "="); + (* Close ": TYPE =" box (depth=2) *) + F.pp_close_box fmt (); + (* Close "QUALIF NAME : TYPE =" box (depth=1) *) + F.pp_close_box fmt (); + + if not is_opaque then ( + F.pp_print_space fmt (); + (* Open "BODY" box (depth=1) *) + F.pp_open_hvbox fmt 0; + (* Print "BODY" *) + (Option.get extract_body) fmt; + (* Close "BODY" box (depth=1) *) + F.pp_close_box fmt ()); + (* Close the definition box (depth=0) *) + F.pp_close_box fmt () + +(** Extract a global declaration. + We generate the body which computes the global value separately from the value declaration itself. + + For example in Rust, + [static X: u32 = 3;] + + will be translated to: + [let x_body : result u32 = Return 3] + [let x_c : u32 = eval_global x_body] + *) +let extract_global_decl (ctx : extraction_ctx) (fmt : F.formatter) + (global : A.global_decl) (body : fun_decl) (interface : bool) : unit = + assert body.is_global_decl_body; + assert (Option.is_none body.back_id); + assert (List.length body.signature.inputs = 0); + assert (List.length body.signature.doutputs = 1); + assert (List.length body.signature.type_params = 0); + + (* Add a break then the name of the corresponding LLBC declaration *) + F.pp_print_break fmt 0 0; + F.pp_print_string fmt + ("(** [" ^ Print.global_name_to_string global.name ^ "] *)"); + F.pp_print_space fmt (); + + let decl_name = ctx_get_global global.def_id ctx in + let body_name = ctx_get_function (Regular global.body_id) None ctx in + + let decl_ty, body_ty = + let ty = body.signature.output in + if body.signature.info.effect_info.can_fail then (unwrap_result_ty ty, ty) + else (ty, mk_result_ty ty) + in + match body.body with + | None -> + let qualif = if interface then Val else AssumeVal in + extract_global_decl_body ctx fmt qualif decl_name decl_ty None + | Some body -> + extract_global_decl_body ctx fmt Let body_name body_ty + (Some (fun fmt -> extract_texpression ctx fmt false body.body)); + F.pp_print_break fmt 0 0; + extract_global_decl_body ctx fmt Let decl_name decl_ty + (Some (fun fmt -> F.pp_print_string fmt ("eval_global " ^ body_name))); + F.pp_print_break fmt 0 0 + +(** Extract a unit test, if the function is a unit function (takes no + parameters, returns unit). + + A unit test simply checks that the function normalizes to [Return ()]: + {[ + let _ = assert_norm (FUNCTION () = Return ()) + ]} + *) +let extract_unit_test_if_unit_fun (ctx : extraction_ctx) (fmt : F.formatter) + (def : fun_decl) : unit = + (* We only insert unit tests for forward functions *) + assert (def.back_id = None); + (* Check if this is a unit function *) + let sg = def.signature in + if + sg.type_params = [] + && (sg.inputs = [ mk_unit_ty ] || sg.inputs = []) + && sg.output = mk_result_ty mk_unit_ty + then ( + (* Add a break before *) + F.pp_print_break fmt 0 0; + (* Print a comment *) + F.pp_print_string fmt + ("(** Unit test for [" ^ Print.fun_name_to_string def.basename ^ "] *)"); + F.pp_print_space fmt (); + (* Open a box for the test *) + F.pp_open_hovbox fmt ctx.indent_incr; + (* Print the test *) + F.pp_print_string fmt "let _ ="; + F.pp_print_space fmt (); + F.pp_print_string fmt "assert_norm"; + F.pp_print_space fmt (); + F.pp_print_string fmt "("; + let fun_name = ctx_get_local_function def.def_id def.back_id ctx in + F.pp_print_string fmt fun_name; + if sg.inputs <> [] then ( + F.pp_print_space fmt (); + F.pp_print_string fmt "()"); + F.pp_print_space fmt (); + F.pp_print_string fmt "="; + F.pp_print_space fmt (); + let success = ctx_get_variant (Assumed Result) result_return_id ctx in + F.pp_print_string fmt (success ^ " ())"); + (* Close the box for the test *) + F.pp_close_box fmt (); + (* Add a break after *) + F.pp_print_break fmt 0 0) + else (* Do nothing *) + () diff --git a/compiler/FunsAnalysis.ml b/compiler/FunsAnalysis.ml new file mode 100644 index 00000000..248ad8b3 --- /dev/null +++ b/compiler/FunsAnalysis.ml @@ -0,0 +1,143 @@ +(** Compute various information, including: + - can a function fail (by having `Fail` in its body, or transitively + calling a function which can fail - this is false for globals) + - can a function diverge (by being recursive, containing a loop or + transitively calling a function which can diverge) + - does a function perform stateful operations (i.e., do we need a state + to translate it) + *) + +open LlbcAst +open Crates +module EU = ExpressionsUtils + +type fun_info = { + can_fail : bool; + (* Not used yet: all the extracted functions use an error monad *) + stateful : bool; + divergent : bool; (* Not used yet *) +} +[@@deriving show] +(** Various information about a function. + + Note that not all this information is used yet to adjust the extraction yet. + *) + +type modules_funs_info = fun_info FunDeclId.Map.t +(** Various information about a module's functions *) + +let analyze_module (m : llbc_crate) (funs_map : fun_decl FunDeclId.Map.t) + (globals_map : global_decl GlobalDeclId.Map.t) (use_state : bool) : + modules_funs_info = + let infos = ref FunDeclId.Map.empty in + + let register_info (id : FunDeclId.id) (info : fun_info) : unit = + assert (not (FunDeclId.Map.mem id !infos)); + infos := FunDeclId.Map.add id info !infos + in + + (* Analyze a group of mutually recursive functions. + * As the functions can call each other, we compute the same information + * for all of them (if one of the functions can fail, then all of them + * can fail, etc.). + * + * We simply check if the functions contains panic statements, loop statements, + * recursive calls, etc. We use the previously computed information in case + * of function calls. + *) + let analyze_fun_decls (fun_ids : FunDeclId.Set.t) (d : fun_decl list) : + fun_info = + let can_fail = ref false in + let stateful = ref false in + let divergent = ref false in + + let visit_fun (f : fun_decl) : unit = + let obj = + object (self) + inherit [_] iter_statement as super + method may_fail b = can_fail := !can_fail || b + + method! visit_Assert env a = + self#may_fail true; + super#visit_Assert env a + + method! visit_rvalue _env rv = + match rv with + | Use _ | Ref _ | Discriminant _ | Aggregate _ -> () + | UnaryOp (uop, _) -> can_fail := EU.unop_can_fail uop || !can_fail + | BinaryOp (bop, _, _) -> + can_fail := EU.binop_can_fail bop || !can_fail + + method! visit_Call env call = + (match call.func with + | Regular id -> + if FunDeclId.Set.mem id fun_ids then divergent := true + else + let info = FunDeclId.Map.find id !infos in + self#may_fail info.can_fail; + stateful := !stateful || info.stateful; + divergent := !divergent || info.divergent + | Assumed id -> + (* None of the assumed functions is stateful for now *) + can_fail := !can_fail || Assumed.assumed_can_fail id); + super#visit_Call env call + + method! visit_Panic env = + self#may_fail true; + super#visit_Panic env + + method! visit_Loop env loop = + divergent := true; + super#visit_Loop env loop + end + in + (* Sanity check: global bodies don't contain stateful calls *) + assert ((not f.is_global_decl_body) || not !stateful); + match f.body with + | None -> + (* Opaque function: we consider they fail by default *) + obj#may_fail true; + stateful := (not f.is_global_decl_body) && use_state + | Some body -> obj#visit_statement () body.body + in + List.iter visit_fun d; + (* We need to know if the declaration group contains a global - note that + * groups containing globals contain exactly one declaration *) + let is_global_decl_body = List.exists (fun f -> f.is_global_decl_body) d in + assert ((not is_global_decl_body) || List.length d == 1); + (* We ignore on purpose functions that cannot fail and consider they *can* + * fail: the result of the analysis is not used yet to adjust the translation + * so that the functions which syntactically can't fail don't use an error monad. + * However, we do keep the result of the analysis for global bodies. + * *) + can_fail := (not is_global_decl_body) || !can_fail; + { can_fail = !can_fail; stateful = !stateful; divergent = !divergent } + in + + let analyze_fun_decl_group (d : fun_declaration_group) : unit = + (* Retrieve the function declarations *) + let funs = match d with NonRec id -> [ id ] | Rec ids -> ids in + let funs = List.map (fun id -> FunDeclId.Map.find id funs_map) funs in + let fun_ids = List.map (fun (d : fun_decl) -> d.def_id) funs in + let fun_ids = FunDeclId.Set.of_list fun_ids in + let info = analyze_fun_decls fun_ids funs in + List.iter (fun (f : fun_decl) -> register_info f.def_id info) funs + in + + let rec analyze_decl_groups (decls : declaration_group list) : unit = + match decls with + | [] -> () + | Type _ :: decls' -> analyze_decl_groups decls' + | Fun decl :: decls' -> + analyze_fun_decl_group decl; + analyze_decl_groups decls' + | Global id :: decls' -> + (* Analyze a global by analyzing its body function *) + let global = GlobalDeclId.Map.find id globals_map in + analyze_fun_decl_group (NonRec global.body_id); + analyze_decl_groups decls' + in + + analyze_decl_groups m.declarations; + + !infos diff --git a/compiler/Identifiers.ml b/compiler/Identifiers.ml new file mode 100644 index 00000000..b022b18d --- /dev/null +++ b/compiler/Identifiers.ml @@ -0,0 +1,139 @@ +module C = Collections + +(** Signature for a module describing an identifier. + + We often need identifiers (for definitions, variables, etc.) and in + order to make sure we don't mix them, we use a generative functor + (see {!IdGen}). +*) +module type Id = sig + type id + + (** Id generator - simply a counter *) + type generator + + val zero : id + val generator_zero : generator + val generator_from_incr_id : id -> generator + val fresh_stateful_generator : unit -> generator ref * (unit -> id) + val mk_stateful_generator : generator -> generator ref * (unit -> id) + val incr : id -> id + + (* TODO: this should be stateful! - but we may want to be able to duplicate + contexts... + Maybe we could have a [fresh] and a [global_fresh] + TODO: change the order of the returned types + *) + val fresh : generator -> id * generator + val to_string : id -> string + val pp_id : Format.formatter -> id -> unit + val show_id : id -> string + val id_of_json : Yojson.Basic.t -> (id, string) result + val compare_id : id -> id -> int + val max : id -> id -> id + val min : id -> id -> id + val pp_generator : Format.formatter -> generator -> unit + val show_generator : generator -> string + val to_int : id -> int + val of_int : int -> id + val nth : 'a list -> id -> 'a + (* TODO: change the signature (invert the index and the list *) + + val nth_opt : 'a list -> id -> 'a option + + (** Update the nth element of the list. + + Raises [Invalid_argument] if the identifier is out of range. + *) + val update_nth : 'a list -> id -> 'a -> 'a list + + val mapi : (id -> 'a -> 'b) -> 'a list -> 'b list + + (** Same as {!mapi}, but where the indices start with 1. + + TODO: generalize to [map_from_i] + *) + val mapi_from1 : (id -> 'a -> 'b) -> 'a list -> 'b list + + val iteri : (id -> 'a -> unit) -> 'a list -> unit + + module Ord : C.OrderedType with type t = id + module Set : C.Set with type elt = id + module Map : C.Map with type key = id +end + +(** Generative functor for identifiers. + + See {!Id}. +*) +module IdGen () : Id = struct + (* TODO: use Z.t *) + type id = int [@@deriving show] + type generator = id [@@deriving show] + + let zero = 0 + let generator_zero = 0 + + let incr x = + (* Identifiers should never overflow (because max_int is a really big + * value - but we really want to make sure we detect overflows if + * they happen *) + if x = max_int then raise (Errors.IntegerOverflow ()) else x + 1 + + let generator_from_incr_id id = incr id + + let mk_stateful_generator g = + let g = ref g in + let fresh () = + let id = !g in + g := incr id; + id + in + (g, fresh) + + let fresh_stateful_generator () = mk_stateful_generator 0 + let fresh gen = (gen, incr gen) + let to_string = string_of_int + let to_int x = x + let of_int x = x + + let id_of_json js = + (* TODO: check boundaries ? *) + match js with + | `Int i -> Ok i + | _ -> Error ("id_of_json: failed on " ^ Yojson.Basic.show js) + + let compare_id = compare + let max id0 id1 = if id0 > id1 then id0 else id1 + let min id0 id1 = if id0 < id1 then id0 else id1 + let nth v id = List.nth v id + let nth_opt v id = List.nth_opt v id + + let rec update_nth vec id v = + match (vec, id) with + | [], _ -> raise (Invalid_argument "Out of range") + | _ :: vec', 0 -> v :: vec' + | x :: vec', _ -> x :: update_nth vec' (id - 1) v + + let mapi = List.mapi + + let mapi_from1 f ls = + let rec aux i ls = + match ls with [] -> [] | x :: ls' -> f i x :: aux (i + 1) ls' + in + aux 1 ls + + let iteri = List.iteri + + module Ord = struct + type t = id + + let compare = compare + let to_string = to_string + let pp_t = pp_id + let show_t = show_id + end + + module Set = C.MakeSet (Ord) + module Map = C.MakeMap (Ord) +end diff --git a/compiler/Interpreter.ml b/compiler/Interpreter.ml new file mode 100644 index 00000000..7f51c5b9 --- /dev/null +++ b/compiler/Interpreter.ml @@ -0,0 +1,396 @@ +open Cps +open InterpreterUtils +open InterpreterProjectors +open InterpreterBorrows +open InterpreterStatements +open LlbcAstUtils +module L = Logging +module T = Types +module A = LlbcAst +module SA = SymbolicAst + +(** The local logger *) +let log = L.interpreter_log + +let compute_type_fun_global_contexts (m : Crates.llbc_crate) : + C.type_context * C.fun_context * C.global_context = + let type_decls_list, _, _ = Crates.split_declarations m.declarations in + let type_decls, fun_decls, global_decls = Crates.compute_defs_maps m in + let type_decls_groups, _funs_defs_groups, _globals_defs_groups = + Crates.split_declarations_to_group_maps m.declarations + in + let type_infos = + TypesAnalysis.analyze_type_declarations type_decls type_decls_list + in + let type_context = { C.type_decls_groups; type_decls; type_infos } in + let fun_context = { C.fun_decls } in + let global_context = { C.global_decls } in + (type_context, fun_context, global_context) + +let initialize_eval_context (type_context : C.type_context) + (fun_context : C.fun_context) (global_context : C.global_context) + (type_vars : T.type_var list) : C.eval_ctx = + C.reset_global_counters (); + { + C.type_context; + C.fun_context; + C.global_context; + C.type_vars; + C.env = [ C.Frame ]; + C.ended_regions = T.RegionId.Set.empty; + } + +(** Initialize an evaluation context to execute a function. + + Introduces local variables initialized in the following manner: + - input arguments are initialized as symbolic values + - the remaining locals are initialized as [⊥] + Abstractions are introduced for the regions present in the function + signature. + + We return: + - the initialized evaluation context + - the list of symbolic values introduced for the input values + - the instantiated function signature + *) +let initialize_symbolic_context_for_fun (type_context : C.type_context) + (fun_context : C.fun_context) (global_context : C.global_context) + (fdef : A.fun_decl) : C.eval_ctx * V.symbolic_value list * A.inst_fun_sig = + (* The abstractions are not initialized the same way as for function + * calls: they contain *loan* projectors, because they "provide" us + * with the input values (which behave as if they had been returned + * by some function calls...). + * Also, note that we properly set the set of parents of every abstraction: + * this should not be necessary, as those abstractions should never be + * *automatically* ended (because ending some borrows requires to end + * one of them), but rather selectively ended when generating code + * for each of the backward functions. We do it only because we can + * do it, and because it gives a bit of sanity. + * *) + let sg = fdef.signature in + (* Create the context *) + let ctx = + initialize_eval_context type_context fun_context global_context + sg.type_params + in + (* Instantiate the signature *) + let type_params = List.map (fun tv -> T.TypeVar tv.T.index) sg.type_params in + let inst_sg = instantiate_fun_sig type_params sg in + (* Create fresh symbolic values for the inputs *) + let input_svs = + List.map (fun ty -> mk_fresh_symbolic_value V.SynthInput ty) inst_sg.inputs + in + (* Initialize the abstractions as empty (i.e., with no avalues) abstractions *) + let call_id = C.fresh_fun_call_id () in + assert (call_id = V.FunCallId.zero); + let compute_abs_avalues (abs : V.abs) (ctx : C.eval_ctx) : + C.eval_ctx * V.typed_avalue list = + (* Project over the values - we use *loan* projectors, as explained above *) + let avalues = + List.map (mk_aproj_loans_value_from_symbolic_value abs.regions) input_svs + in + (ctx, avalues) + in + let region_can_end _ = true in + let ctx = + create_push_abstractions_from_abs_region_groups call_id V.SynthInput + inst_sg.A.regions_hierarchy region_can_end compute_abs_avalues ctx + in + (* Split the variables between return var, inputs and remaining locals *) + let body = Option.get fdef.body in + let ret_var = List.hd body.locals in + let input_vars, local_vars = + Collections.List.split_at (List.tl body.locals) body.arg_count + in + (* Push the return variable (initialized with ⊥) *) + let ctx = C.ctx_push_uninitialized_var ctx ret_var in + (* Push the input variables (initialized with symbolic values) *) + let input_values = List.map mk_typed_value_from_symbolic_value input_svs in + let ctx = C.ctx_push_vars ctx (List.combine input_vars input_values) in + (* Push the remaining local variables (initialized with ⊥) *) + let ctx = C.ctx_push_uninitialized_vars ctx local_vars in + (* Return *) + (ctx, input_svs, inst_sg) + +(** Small helper. + + This is a continuation function called by the symbolic interpreter upon + reaching the [return] instruction when synthesizing a *backward* function: + this continuation takes care of doing the proper manipulations to finish + the synthesis (mostly by ending abstractions). +*) +let evaluate_function_symbolic_synthesize_backward_from_return + (config : C.config) (fdef : A.fun_decl) (inst_sg : A.inst_fun_sig) + (back_id : T.RegionGroupId.id) (ctx : C.eval_ctx) : SA.expression option = + (* We need to instantiate the function signature - to retrieve + * the return type. Note that it is important to re-generate + * an instantiation of the signature, so that we use fresh + * region ids for the return abstractions. *) + let sg = fdef.signature in + let type_params = List.map (fun tv -> T.TypeVar tv.T.index) sg.type_params in + let ret_inst_sg = instantiate_fun_sig type_params sg in + let ret_rty = ret_inst_sg.output in + (* Move the return value out of the return variable *) + let cf_pop_frame = ctx_pop_frame config in + + (* We need to find the parents regions/abstractions of the region we + * will end - this will allow us to, first, mark the other return + * regions as non-endable, and, second, end those parent regions in + * proper order. *) + let parent_rgs = list_parent_region_groups sg back_id in + let parent_input_abs_ids = + T.RegionGroupId.mapi + (fun rg_id rg -> + if T.RegionGroupId.Set.mem rg_id parent_rgs then Some rg.T.id else None) + inst_sg.regions_hierarchy + in + let parent_input_abs_ids = + List.filter_map (fun x -> x) parent_input_abs_ids + in + + (* Insert the return value in the return abstractions (by applying + * borrow projections) *) + let cf_consume_ret ret_value ctx = + let ret_call_id = C.fresh_fun_call_id () in + let compute_abs_avalues (abs : V.abs) (ctx : C.eval_ctx) : + C.eval_ctx * V.typed_avalue list = + let ctx, avalue = + apply_proj_borrows_on_input_value config ctx abs.regions + abs.ancestors_regions ret_value ret_rty + in + (ctx, [ avalue ]) + in + + (* Initialize and insert the abstractions in the context. + * + * We take care of disallowing ending the return regions which we + * shouldn't end (see the documentation of the [can_end] field of [abs] + * for more information. *) + let parent_and_current_rgs = T.RegionGroupId.Set.add back_id parent_rgs in + let region_can_end rid = + T.RegionGroupId.Set.mem rid parent_and_current_rgs + in + assert (region_can_end back_id); + let ctx = + create_push_abstractions_from_abs_region_groups ret_call_id V.SynthRet + ret_inst_sg.A.regions_hierarchy region_can_end compute_abs_avalues ctx + in + + (* We now need to end the proper *input* abstractions - pay attention + * to the fact that we end the *input* abstractions, not the *return* + * abstractions (of course, the corresponding return abstractions will + * automatically be ended, because they consumed values coming from the + * input abstractions...) *) + (* End the parent abstractions and the current abstraction - note that we + * end them in an order which follows the regions hierarchy: it should lead + * to generated code which has a better consistency between the parent + * and children backward functions *) + let current_abs_id = + (T.RegionGroupId.nth inst_sg.regions_hierarchy back_id).id + in + let target_abs_ids = List.append parent_input_abs_ids [ current_abs_id ] in + let cf_end_target_abs cf = + List.fold_left + (fun cf id -> end_abstraction config [] id cf) + cf target_abs_ids + in + (* Generate the Return node *) + let cf_return : m_fun = fun _ -> Some (SA.Return None) in + (* Apply *) + cf_end_target_abs cf_return ctx + in + cf_pop_frame cf_consume_ret ctx + +(** Evaluate a function with the symbolic interpreter. + + We return: + - the list of symbolic values introduced for the input values (this is useful + for the synthesis) + - the symbolic AST generated by the symbolic execution + *) +let evaluate_function_symbolic (config : C.partial_config) (synthesize : bool) + (type_context : C.type_context) (fun_context : C.fun_context) + (global_context : C.global_context) (fdef : A.fun_decl) + (back_id : T.RegionGroupId.id option) : + V.symbolic_value list * SA.expression option = + (* Debug *) + let name_to_string () = + Print.fun_name_to_string fdef.A.name + ^ " (" + ^ Print.option_to_string T.RegionGroupId.to_string back_id + ^ ")" + in + log#ldebug (lazy ("evaluate_function_symbolic: " ^ name_to_string ())); + + (* Create the evaluation context *) + let ctx, input_svs, inst_sg = + initialize_symbolic_context_for_fun type_context fun_context global_context + fdef + in + + (* Create the continuation to finish the evaluation *) + let config = C.config_of_partial C.SymbolicMode config in + let cf_finish res ctx = + match res with + | Return -> + if synthesize then + (* There are two cases: + * - if this is a forward translation, we retrieve the returned value. + * - if this is a backward translation, we introduce "return" + * abstractions to consume the return value, then end all the + * abstractions up to the one in which we are interested. + *) + match back_id with + | None -> + (* Forward translation *) + (* Pop the frame and retrieve the returned value at the same time*) + let cf_pop = ctx_pop_frame config in + (* Generate the Return node *) + let cf_return ret_value : m_fun = + fun _ -> Some (SA.Return (Some ret_value)) + in + (* Apply *) + cf_pop cf_return ctx + | Some back_id -> + (* Backward translation *) + evaluate_function_symbolic_synthesize_backward_from_return config + fdef inst_sg back_id ctx + else None + | Panic -> + (* Note that as we explore all the execution branches, one of + * the executions can lead to a panic *) + if synthesize then Some SA.Panic else None + | _ -> + failwith ("evaluate_function_symbolic failed on: " ^ name_to_string ()) + in + + (* Evaluate the function *) + let symbolic = + eval_function_body config (Option.get fdef.A.body).body cf_finish ctx + in + + (* Return *) + (input_svs, symbolic) + +module Test = struct + (** Test a unit function (taking no arguments) by evaluating it in an empty + environment. + *) + let test_unit_function (config : C.partial_config) (crate : Crates.llbc_crate) + (fid : A.FunDeclId.id) : unit = + (* Retrieve the function declaration *) + let fdef = A.FunDeclId.nth crate.functions fid in + let body = Option.get fdef.body in + + (* Debug *) + log#ldebug + (lazy ("test_unit_function: " ^ Print.fun_name_to_string fdef.A.name)); + + (* Sanity check - *) + assert (List.length fdef.A.signature.region_params = 0); + assert (List.length fdef.A.signature.type_params = 0); + assert (body.A.arg_count = 0); + + (* Create the evaluation context *) + let type_context, fun_context, global_context = + compute_type_fun_global_contexts crate + in + let ctx = + initialize_eval_context type_context fun_context global_context [] + in + + (* Insert the (uninitialized) local variables *) + let ctx = C.ctx_push_uninitialized_vars ctx body.A.locals in + + (* Create the continuation to check the function's result *) + let config = C.config_of_partial C.ConcreteMode config in + let cf_check res ctx = + match res with + | Return -> + (* Ok: drop the local variables and finish *) + ctx_pop_frame config (fun _ _ -> None) ctx + | _ -> + failwith + ("Unit test failed (concrete execution) on: " + ^ Print.fun_name_to_string fdef.A.name) + in + + (* Evaluate the function *) + let _ = eval_function_body config body.body cf_check ctx in + () + + (** Small helper: return true if the function is a *transparent* unit function + (no parameters, no arguments) - TODO: move *) + let fun_decl_is_transparent_unit (def : A.fun_decl) : bool = + match def.body with + | None -> false + | Some body -> + body.arg_count = 0 + && List.length def.A.signature.region_params = 0 + && List.length def.A.signature.type_params = 0 + && List.length def.A.signature.inputs = 0 + + (** Test all the unit functions in a list of function definitions *) + let test_unit_functions (config : C.partial_config) + (crate : Crates.llbc_crate) : unit = + let unit_funs = List.filter fun_decl_is_transparent_unit crate.functions in + let test_unit_fun (def : A.fun_decl) : unit = + test_unit_function config crate def.A.def_id + in + List.iter test_unit_fun unit_funs + + (** Execute the symbolic interpreter on a function. *) + let test_function_symbolic (config : C.partial_config) (synthesize : bool) + (type_context : C.type_context) (fun_context : C.fun_context) + (global_context : C.global_context) (fdef : A.fun_decl) : unit = + (* Debug *) + log#ldebug + (lazy ("test_function_symbolic: " ^ Print.fun_name_to_string fdef.A.name)); + + (* Evaluate *) + let evaluate = + evaluate_function_symbolic config synthesize type_context fun_context + global_context fdef + in + (* Execute the forward function *) + let _ = evaluate None in + (* Execute the backward functions *) + let _ = + T.RegionGroupId.mapi + (fun gid _ -> evaluate (Some gid)) + fdef.signature.regions_hierarchy + in + + () + + (** Small helper *) + let fun_decl_is_transparent (def : A.fun_decl) : bool = + Option.is_some def.body + + (** Execute the symbolic interpreter on a list of functions. + + TODO: for now we ignore the functions which contain loops, because + they are not supported by the symbolic interpreter. + *) + let test_functions_symbolic (config : C.partial_config) (synthesize : bool) + (crate : Crates.llbc_crate) : unit = + (* Filter the functions which contain loops *) + let no_loop_funs = + List.filter + (fun f -> not (LlbcAstUtils.fun_decl_has_loops f)) + crate.functions + in + (* Filter the opaque functions *) + let no_loop_funs = List.filter fun_decl_is_transparent no_loop_funs in + let type_context, fun_context, global_context = + compute_type_fun_global_contexts crate + in + let test_fun (def : A.fun_decl) : unit = + (* Execute the function - note that as the symbolic interpreter explores + * all the path, some executions are expected to "panic": we thus don't + * check the return value *) + test_function_symbolic config synthesize type_context fun_context + global_context def + in + List.iter test_fun no_loop_funs +end diff --git a/compiler/InterpreterBorrows.ml b/compiler/InterpreterBorrows.ml new file mode 100644 index 00000000..30c3b221 --- /dev/null +++ b/compiler/InterpreterBorrows.ml @@ -0,0 +1,1580 @@ +module T = Types +module V = Values +module C = Contexts +module Subst = Substitute +module L = Logging +module S = SynthesizeSymbolic +open Cps +open ValuesUtils +open TypesUtils +open InterpreterUtils +open InterpreterBorrowsCore +open InterpreterProjectors + +(** The local logger *) +let log = InterpreterBorrowsCore.log + +(** Auxiliary function to end borrows: lookup a borrow in the environment, + update it (by returning an updated environment where the borrow has been + replaced by {!V.Bottom})) if we can end the borrow (for instance, it is not + an outer borrow...) or return the reason why we couldn't update the borrow. + + [end_borrow] then simply performs a loop: as long as we need to end (outer) + borrows, we end them, before finally ending the borrow we wanted to end in the + first place. + + Note that it is possible to end a borrow in an abstraction, without ending + the whole abstraction, if the corresponding loan is inside the abstraction + as well. The [allowed_abs] parameter controls whether we allow to end borrows + in an abstraction or not, and in which abstraction. +*) +let end_borrow_get_borrow (allowed_abs : V.AbstractionId.id option) + (l : V.BorrowId.id) (ctx : C.eval_ctx) : + (C.eval_ctx * g_borrow_content option, priority_borrows_or_abs) result = + (* We use a reference to communicate the kind of borrow we found, if we + * find one *) + let replaced_bc : g_borrow_content option ref = ref None in + let set_replaced_bc (bc : g_borrow_content) = + assert (Option.is_none !replaced_bc); + replaced_bc := Some bc + in + (* Raise an exception if: + * - there are outer borrows + * - if we are inside an abstraction + * - there are inner loans + * this exception is caught in a wrapper function *) + let raise_if_priority (outer : V.AbstractionId.id option * borrow_ids option) + (borrowed_value : V.typed_value option) = + (* First, look for outer borrows or abstraction *) + let outer_abs, outer_borrows = outer in + (match outer_abs with + | Some abs -> ( + if + (* Check if we can end borrows inside this abstraction *) + Some abs <> allowed_abs + then raise (FoundPriority (OuterAbs abs)) + else + match outer_borrows with + | Some borrows -> raise (FoundPriority (OuterBorrows borrows)) + | None -> ()) + | None -> ( + match outer_borrows with + | Some borrows -> raise (FoundPriority (OuterBorrows borrows)) + | None -> ())); + (* Then check if there are inner loans *) + match borrowed_value with + | None -> () + | Some v -> ( + match get_first_loan_in_value v with + | None -> () + | Some c -> ( + match c with + | V.SharedLoan (bids, _) -> + raise (FoundPriority (InnerLoans (Borrows bids))) + | V.MutLoan bid -> raise (FoundPriority (InnerLoans (Borrow bid))))) + in + + (* The environment is used to keep track of the outer loans *) + let obj = + object + inherit [_] C.map_eval_ctx as super + + (** We reimplement {!visit_Loan} because we may have to update the + outer borrows *) + method! visit_Loan (outer : V.AbstractionId.id option * borrow_ids option) + lc = + match lc with + | V.MutLoan bid -> V.Loan (super#visit_MutLoan outer bid) + | V.SharedLoan (bids, v) -> + (* Update the outer borrows before diving into the shared value *) + let outer = update_outer_borrows outer (Borrows bids) in + V.Loan (super#visit_SharedLoan outer bids v) + + method! visit_Borrow outer bc = + match bc with + | SharedBorrow (_, l') | InactivatedMutBorrow (_, l') -> + (* Check if this is the borrow we are looking for *) + if l = l' then ( + (* Check if there are outer borrows or if we are inside an abstraction *) + raise_if_priority outer None; + (* Register the update *) + set_replaced_bc (Concrete bc); + (* Update the value *) + V.Bottom) + else super#visit_Borrow outer bc + | V.MutBorrow (l', bv) -> + (* Check if this is the borrow we are looking for *) + if l = l' then ( + (* Check if there are outer borrows or if we are inside an abstraction *) + raise_if_priority outer (Some bv); + (* Register the update *) + set_replaced_bc (Concrete bc); + (* Update the value *) + V.Bottom) + else + (* Update the outer borrows before diving into the borrowed value *) + let outer = update_outer_borrows outer (Borrow l') in + V.Borrow (super#visit_MutBorrow outer l' bv) + + (** We reimplement {!visit_ALoan} because we may have to update the + outer borrows *) + method! visit_ALoan outer lc = + (* Note that the children avalues are just other, independent loans, + * so we don't need to update the outer borrows when diving in. + * We keep track of the parents/children relationship only because we + * need it to properly instantiate the backward functions when generating + * the pure translation. *) + match lc with + | V.AMutLoan (_, _) -> + (* Nothing special to do *) + super#visit_ALoan outer lc + | V.ASharedLoan (bids, v, av) -> + (* Explore the shared value - we need to update the outer borrows *) + let souter = update_outer_borrows outer (Borrows bids) in + let v = super#visit_typed_value souter v in + (* Explore the child avalue - we keep the same outer borrows *) + let av = super#visit_typed_avalue outer av in + (* Reconstruct *) + V.ALoan (V.ASharedLoan (bids, v, av)) + | V.AEndedMutLoan { given_back = _; child = _; given_back_meta = _ } + | V.AEndedSharedLoan _ + (* The loan has ended, so no need to update the outer borrows *) + | V.AIgnoredMutLoan _ (* Nothing special to do *) + | V.AEndedIgnoredMutLoan + { given_back = _; child = _; given_back_meta = _ } + (* Nothing special to do *) + | V.AIgnoredSharedLoan _ -> + (* Nothing special to do *) + super#visit_ALoan outer lc + + method! visit_ABorrow outer bc = + match bc with + | V.AMutBorrow (_, bid, _) -> + (* Check if this is the borrow we are looking for *) + if bid = l then ( + (* When ending a mut borrow, there are two cases: + * - in the general case, we have to end the whole abstraction + * (and thus raise an exception to signal that to the caller) + * - in some situations, the associated loan is inside the same + * abstraction as the borrow. In this situation, we can end + * the borrow without ending the whole abstraction, and we + * simply move the child avalue around. + *) + (* Check there are outer borrows, or if we need to end the whole + * abstraction *) + raise_if_priority outer None; + (* Register the update *) + set_replaced_bc (Abstract bc); + (* Update the value - note that we are necessarily in the second + * of the two cases described above. + * Also note that, as we are moving the borrowed value inside the + * abstraction (and not really giving the value back to the context) + * we do not insert {!AEndedMutBorrow} but rather {!ABottom} *) + V.ABottom) + else + (* Update the outer borrows before diving into the child avalue *) + let outer = update_outer_borrows outer (Borrow bid) in + super#visit_ABorrow outer bc + | V.ASharedBorrow bid -> + (* Check if this is the borrow we are looking for *) + if bid = l then ( + (* Check there are outer borrows, or if we need to end the whole + * abstraction *) + raise_if_priority outer None; + (* Register the update *) + set_replaced_bc (Abstract bc); + (* Update the value - note that we are necessarily in the second + * of the two cases described above *) + V.ABottom) + else super#visit_ABorrow outer bc + | V.AIgnoredMutBorrow (_, _) + | V.AEndedMutBorrow _ + | V.AEndedIgnoredMutBorrow + { given_back_loans_proj = _; child = _; given_back_meta = _ } + | V.AEndedSharedBorrow -> + (* Nothing special to do *) + super#visit_ABorrow outer bc + | V.AProjSharedBorrow asb -> + (* Check if the borrow we are looking for is in the asb *) + if borrow_in_asb l asb then ( + (* Check there are outer borrows, or if we need to end the whole + * abstraction *) + raise_if_priority outer None; + (* Register the update *) + set_replaced_bc (Abstract bc); + (* Update the value - note that we are necessarily in the second + * of the two cases described above *) + let asb = remove_borrow_from_asb l asb in + V.ABorrow (V.AProjSharedBorrow asb)) + else (* Nothing special to do *) + super#visit_ABorrow outer bc + + method! visit_abs outer abs = + (* Update the outer abs *) + let outer_abs, outer_borrows = outer in + assert (Option.is_none outer_abs); + assert (Option.is_none outer_borrows); + let outer = (Some abs.V.abs_id, None) in + super#visit_abs outer abs + end + in + (* Catch the exceptions - raised if there are outer borrows *) + try + let ctx = obj#visit_eval_ctx (None, None) ctx in + Ok (ctx, !replaced_bc) + with FoundPriority outers -> Error outers + +(** Auxiliary function to end borrows. See [give_back]. + + When we end a mutable borrow, we need to "give back" the value it contained + to its original owner by reinserting it at the proper position. + + Note that this function checks that there is exactly one loan to which we + give the value back. + TODO: this was not the case before, so some sanity checks are not useful anymore. + *) +let give_back_value (config : C.config) (bid : V.BorrowId.id) + (nv : V.typed_value) (ctx : C.eval_ctx) : C.eval_ctx = + (* Sanity check *) + assert (not (loans_in_value nv)); + assert (not (bottom_in_value ctx.ended_regions nv)); + (* Debug *) + log#ldebug + (lazy + ("give_back_value:\n- bid: " ^ V.BorrowId.to_string bid ^ "\n- value: " + ^ typed_value_to_string ctx nv + ^ "\n- context:\n" ^ eval_ctx_to_string ctx ^ "\n")); + (* We use a reference to check that we updated exactly one loan *) + let replaced : bool ref = ref false in + let set_replaced () = + assert (not !replaced); + replaced := true + in + (* Whenever giving back symbolic values, they shouldn't contain already ended regions *) + let check_symbolic_no_ended = true in + (* We sometimes need to reborrow values while giving a value back due: prepare that *) + let allow_reborrows = true in + let fresh_reborrow, apply_registered_reborrows = + prepare_reborrows config allow_reborrows + in + (* The visitor to give back the values *) + let obj = + object (self) + inherit [_] C.map_eval_ctx as super + + (** This is a bit annoying, but as we need the type of the value we + are exploring, for sanity checks, we need to implement + {!visit_typed_avalue} instead of + overriding {!visit_ALoan} *) + method! visit_typed_value opt_abs (v : V.typed_value) : V.typed_value = + match v.V.value with + | V.Loan lc -> + let value = self#visit_typed_Loan opt_abs v.V.ty lc in + ({ v with V.value } : V.typed_value) + | _ -> super#visit_typed_value opt_abs v + + method visit_typed_Loan opt_abs ty lc = + match lc with + | V.SharedLoan (bids, v) -> + (* We are giving back a value (i.e., the content of a *mutable* + * borrow): nothing special to do *) + V.Loan (super#visit_SharedLoan opt_abs bids v) + | V.MutLoan bid' -> + (* Check if this is the loan we are looking for *) + if bid' = bid then ( + (* Sanity check *) + let expected_ty = ty in + if nv.V.ty <> expected_ty then ( + log#serror + ("give_back_value: improper type:\n- expected: " + ^ ety_to_string ctx ty ^ "\n- received: " + ^ ety_to_string ctx nv.V.ty); + failwith "Value given back doesn't have the proper type"); + (* Replace *) + set_replaced (); + nv.V.value) + else V.Loan (super#visit_MutLoan opt_abs bid') + + (** This is a bit annoying, but as we need the type of the avalue we + are exploring, in order to be able to project the value we give + back, we need to reimplement {!visit_typed_avalue} instead of + {!visit_ALoan} *) + method! visit_typed_avalue opt_abs (av : V.typed_avalue) : V.typed_avalue + = + match av.V.value with + | V.ALoan lc -> + let value = self#visit_typed_ALoan opt_abs av.V.ty lc in + ({ av with V.value } : V.typed_avalue) + | _ -> super#visit_typed_avalue opt_abs av + + (** We need to inspect ignored mutable borrows, to insert loan projectors + if necessary. + *) + method! visit_ABorrow (opt_abs : V.abs option) (bc : V.aborrow_content) + : V.avalue = + match bc with + | V.AIgnoredMutBorrow (bid', child) -> + if bid' = Some bid then + (* Insert a loans projector - note that if this case happens, + * it is necessarily because we ended a parent abstraction, + * and the given back value is thus a symbolic value *) + match nv.V.value with + | V.Symbolic sv -> + let abs = Option.get opt_abs in + (* Remember the given back value as a meta-value + * TODO: it is a bit annoying to have to deconstruct + * the value... Think about a more elegant way. *) + let given_back_meta = as_symbolic nv.value in + (* The loan projector *) + let given_back_loans_proj = + mk_aproj_loans_value_from_symbolic_value abs.regions sv + in + (* Continue giving back in the child value *) + let child = super#visit_typed_avalue opt_abs child in + (* Return *) + V.ABorrow + (V.AEndedIgnoredMutBorrow + { given_back_loans_proj; child; given_back_meta }) + | _ -> failwith "Unreachable" + else + (* Continue exploring *) + V.ABorrow (super#visit_AIgnoredMutBorrow opt_abs bid' child) + | _ -> + (* Continue exploring *) + super#visit_ABorrow opt_abs bc + + (** We are not specializing an already existing method, but adding a + new method (for projections, we need type information) *) + method visit_typed_ALoan (opt_abs : V.abs option) (ty : T.rty) + (lc : V.aloan_content) : V.avalue = + (* Preparing a bit *) + let regions, ancestors_regions = + match opt_abs with + | None -> failwith "Unreachable" + | Some abs -> (abs.V.regions, abs.V.ancestors_regions) + in + (* Rk.: there is a small issue with the types of the aloan values. + * See the comment at the level of definition of {!typed_avalue} *) + let borrowed_value_aty = + let _, ty, _ = ty_get_ref ty in + ty + in + match lc with + | V.AMutLoan (bid', child) -> + if bid' = bid then ( + (* This is the loan we are looking for: apply the projection to + * the value we give back and replaced this mutable loan with + * an ended loan *) + (* Register the insertion *) + set_replaced (); + (* Remember the given back value as a meta-value *) + let given_back_meta = nv in + (* Apply the projection *) + let given_back = + apply_proj_borrows check_symbolic_no_ended ctx fresh_reborrow + regions ancestors_regions nv borrowed_value_aty + in + (* Continue giving back in the child value *) + let child = super#visit_typed_avalue opt_abs child in + (* Return the new value *) + V.ALoan (V.AEndedMutLoan { child; given_back; given_back_meta })) + else (* Continue exploring *) + super#visit_ALoan opt_abs lc + | V.ASharedLoan (_, _, _) -> + (* We are giving back a value to a *mutable* loan: nothing special to do *) + super#visit_ALoan opt_abs lc + | V.AEndedMutLoan { child = _; given_back = _; given_back_meta = _ } + | V.AEndedSharedLoan (_, _) -> + (* Nothing special to do *) + super#visit_ALoan opt_abs lc + | V.AIgnoredMutLoan (bid', child) -> + (* This loan is ignored, but we may have to project on a subvalue + * of the value which is given back *) + if bid' = bid then + (* Remember the given back value as a meta-value *) + let given_back_meta = nv in + (* Note that we replace the ignored mut loan by an *ended* ignored + * mut loan. Also, this is not the loan we are looking for *per se*: + * we don't register the fact that we inserted the value somewhere + * (i.e., we don't call {!set_replaced}) *) + let given_back = + apply_proj_borrows check_symbolic_no_ended ctx fresh_reborrow + regions ancestors_regions nv borrowed_value_aty + in + (* Continue giving back in the child value *) + let child = super#visit_typed_avalue opt_abs child in + V.ALoan + (V.AEndedIgnoredMutLoan { given_back; child; given_back_meta }) + else super#visit_ALoan opt_abs lc + | V.AEndedIgnoredMutLoan + { given_back = _; child = _; given_back_meta = _ } + | V.AIgnoredSharedLoan _ -> + (* Nothing special to do *) + super#visit_ALoan opt_abs lc + + method! visit_Abs opt_abs abs = + (* We remember in which abstraction we are before diving - + * this is necessary for projecting values: we need to know + * over which regions to project *) + assert (Option.is_none opt_abs); + super#visit_Abs (Some abs) abs + end + in + + (* Explore the environment *) + let ctx = obj#visit_eval_ctx None ctx in + (* Check we gave back to exactly one loan *) + assert !replaced; + (* Apply the reborrows *) + apply_registered_reborrows ctx + +(** Give back a *modified* symbolic value. *) +let give_back_symbolic_value (_config : C.config) + (proj_regions : T.RegionId.Set.t) (proj_ty : T.rty) (sv : V.symbolic_value) + (nsv : V.symbolic_value) (ctx : C.eval_ctx) : C.eval_ctx = + (* Sanity checks *) + assert (sv.sv_id <> nsv.sv_id); + (match nsv.sv_kind with + | V.SynthInputGivenBack | V.SynthRetGivenBack | V.FunCallGivenBack -> () + | V.FunCallRet | V.SynthInput | V.Global -> failwith "Unrechable"); + (* Store the given-back value as a meta-value for synthesis purposes *) + let mv = nsv in + (* Substitution function, to replace the borrow projectors over symbolic values *) + let subst (_abs : V.abs) local_given_back = + (* See the below comments: there is something wrong here *) + let _ = raise Errors.Unimplemented in + (* Compute the projection over the given back value *) + let child_proj = + match nsv.sv_kind with + | V.SynthRetGivenBack -> + (* The given back value comes from the return value of the function + we are currently synthesizing (as it is given back, it means + we ended one of the regions appearing in the signature: we are + currently synthesizing one of the backward functions). + + As we don't allow borrow overwrites on returned value, we can + (and MUST) forget the borrows *) + V.AIgnoredProjBorrows + | V.FunCallGivenBack -> + (* TODO: there is something wrong here. + Consider this: + {[ + abs0 {'a} { AProjLoans (s0 : &'a mut T) [] } + abs1 {'b} { AProjBorrows (s0 : &'a mut T <: &'b mut T) } + ]} + + Upon ending abs1, we give back some fresh symbolic value [s1], + that we reinsert where the loan for [s0] is. However, the mutable + borrow in the type [&'a mut T] was ended: we give back a value of + type [T]! We thus *mustn't* introduce a projector here. + *) + V.AProjBorrows (nsv, sv.V.sv_ty) + | _ -> failwith "Unreachable" + in + V.AProjLoans (sv, (mv, child_proj) :: local_given_back) + in + update_intersecting_aproj_loans proj_regions proj_ty sv subst ctx + +(** Auxiliary function to end borrows. See [give_back]. + + This function is similar to {!give_back_value} but gives back an {!V.avalue} + (coming from an abstraction). + + It is used when ending a borrow inside an abstraction, when the corresponding + loan is inside the same abstraction (in which case we don't need to end the whole + abstraction). + + REMARK: this function can't be used to give back the values borrowed by + end abstraction when ending this abstraction. When doing this, we need + to convert the {!V.avalue} to a {!type:V.value} by introducing the proper symbolic values. + *) +let give_back_avalue_to_same_abstraction (_config : C.config) + (bid : V.BorrowId.id) (mv : V.mvalue) (nv : V.typed_avalue) + (ctx : C.eval_ctx) : C.eval_ctx = + (* We use a reference to check that we updated exactly one loan *) + let replaced : bool ref = ref false in + let set_replaced () = + assert (not !replaced); + replaced := true + in + let obj = + object (self) + inherit [_] C.map_eval_ctx as super + + (** This is a bit annoying, but as we need the type of the avalue we + are exploring, in order to be able to project the value we give + back, we need to reimplement {!visit_typed_avalue} instead of + {!visit_ALoan} *) + method! visit_typed_avalue opt_abs (av : V.typed_avalue) : V.typed_avalue + = + match av.V.value with + | V.ALoan lc -> + let value = self#visit_typed_ALoan opt_abs av.V.ty lc in + ({ av with V.value } : V.typed_avalue) + | _ -> super#visit_typed_avalue opt_abs av + + (** We are not specializing an already existing method, but adding a + new method (for projections, we need type information) *) + method visit_typed_ALoan (opt_abs : V.abs option) (ty : T.rty) + (lc : V.aloan_content) : V.avalue = + match lc with + | V.AMutLoan (bid', child) -> + if bid' = bid then ( + (* Sanity check - about why we need to call {!ty_get_ref} + * (and don't do the same thing as in {!give_back_value}) + * see the comment at the level of the definition of + * {!typed_avalue} *) + let _, expected_ty, _ = ty_get_ref ty in + if nv.V.ty <> expected_ty then ( + log#serror + ("give_back_avalue_to_same_abstraction: improper type:\n\ + - expected: " ^ rty_to_string ctx ty ^ "\n- received: " + ^ rty_to_string ctx nv.V.ty); + failwith "Value given back doesn't have the proper type"); + (* This is the loan we are looking for: apply the projection to + * the value we give back and replaced this mutable loan with + * an ended loan *) + (* Register the insertion *) + set_replaced (); + (* Return the new value *) + V.ALoan + (V.AEndedMutLoan + { given_back = nv; child; given_back_meta = mv })) + else (* Continue exploring *) + super#visit_ALoan opt_abs lc + | V.ASharedLoan (_, _, _) + (* We are giving back a value to a *mutable* loan: nothing special to do *) + | V.AEndedMutLoan { given_back = _; child = _; given_back_meta = _ } + | V.AEndedSharedLoan (_, _) -> + (* Nothing special to do *) + super#visit_ALoan opt_abs lc + | V.AIgnoredMutLoan (bid', child) -> + (* This loan is ignored, but we may have to project on a subvalue + * of the value which is given back *) + if bid' = bid then ( + (* Note that we replace the ignored mut loan by an *ended* ignored + * mut loan. Also, this is not the loan we are looking for *per se*: + * we don't register the fact that we inserted the value somewhere + * (i.e., we don't call {!set_replaced}) *) + (* Sanity check *) + assert (nv.V.ty = ty); + V.ALoan + (V.AEndedIgnoredMutLoan + { given_back = nv; child; given_back_meta = mv })) + else super#visit_ALoan opt_abs lc + | V.AEndedIgnoredMutLoan + { given_back = _; child = _; given_back_meta = _ } + | V.AIgnoredSharedLoan _ -> + (* Nothing special to do *) + super#visit_ALoan opt_abs lc + end + in + + (* Explore the environment *) + let ctx = obj#visit_eval_ctx None ctx in + (* Check we gave back to exactly one loan *) + assert !replaced; + (* Return *) + ctx + +(** Auxiliary function to end borrows. See [give_back]. + + When we end a shared borrow, we need to remove the borrow id from the list + of borrows to the shared value. + + Note that this function checks that there is exactly one shared loan that + we update. + TODO: this was not the case before, so some sanity checks are not useful anymore. + *) +let give_back_shared _config (bid : V.BorrowId.id) (ctx : C.eval_ctx) : + C.eval_ctx = + (* We use a reference to check that we updated exactly one loan *) + let replaced : bool ref = ref false in + let set_replaced () = + assert (not !replaced); + replaced := true + in + let obj = + object + inherit [_] C.map_eval_ctx as super + + method! visit_Loan opt_abs lc = + match lc with + | V.SharedLoan (bids, shared_value) -> + if V.BorrowId.Set.mem bid bids then ( + (* This is the loan we are looking for *) + set_replaced (); + (* If there remains exactly one borrow identifier, we need + * to end the loan. Otherwise, we just remove the current + * loan identifier *) + if V.BorrowId.Set.cardinal bids = 1 then shared_value.V.value + else + V.Loan + (V.SharedLoan (V.BorrowId.Set.remove bid bids, shared_value))) + else + (* Not the loan we are looking for: continue exploring *) + V.Loan (super#visit_SharedLoan opt_abs bids shared_value) + | V.MutLoan bid' -> + (* We are giving back a *shared* borrow: nothing special to do *) + V.Loan (super#visit_MutLoan opt_abs bid') + + method! visit_ALoan opt_abs lc = + match lc with + | V.AMutLoan (bid, av) -> + (* Nothing special to do (we are giving back a *shared* borrow) *) + V.ALoan (super#visit_AMutLoan opt_abs bid av) + | V.ASharedLoan (bids, shared_value, child) -> + if V.BorrowId.Set.mem bid bids then ( + (* This is the loan we are looking for *) + set_replaced (); + (* If there remains exactly one borrow identifier, we need + * to end the loan. Otherwise, we just remove the current + * loan identifier *) + if V.BorrowId.Set.cardinal bids = 1 then + V.ALoan (V.AEndedSharedLoan (shared_value, child)) + else + V.ALoan + (V.ASharedLoan + (V.BorrowId.Set.remove bid bids, shared_value, child))) + else + (* Not the loan we are looking for: continue exploring *) + super#visit_ALoan opt_abs lc + | V.AEndedMutLoan { given_back = _; child = _; given_back_meta = _ } + (* Nothing special to do (the loan has ended) *) + | V.AEndedSharedLoan (_, _) + (* Nothing special to do (the loan has ended) *) + | V.AIgnoredMutLoan (_, _) + (* Nothing special to do (we are giving back a *shared* borrow) *) + | V.AEndedIgnoredMutLoan + { given_back = _; child = _; given_back_meta = _ } + (* Nothing special to do *) + | V.AIgnoredSharedLoan _ -> + (* Nothing special to do *) + super#visit_ALoan opt_abs lc + end + in + + (* Explore the environment *) + let ctx = obj#visit_eval_ctx None ctx in + (* Check we gave back to exactly one loan *) + assert !replaced; + (* Return *) + ctx + +(** When copying values, we duplicate the shared borrows. This is tantamount + to reborrowing the shared value. The following function applies this change + to an environment by inserting a new borrow id in the set of borrows tracked + by a shared value, referenced by the [original_bid] argument. + *) +let reborrow_shared (original_bid : V.BorrowId.id) (new_bid : V.BorrowId.id) + (ctx : C.eval_ctx) : C.eval_ctx = + (* Keep track of changes *) + let r = ref false in + let set_ref () = + assert (not !r); + r := true + in + + let obj = + object + inherit [_] C.map_env as super + + method! visit_SharedLoan env bids sv = + (* Shared loan: check if the borrow id we are looking for is in the + set of borrow ids. If yes, insert the new borrow id, otherwise + explore inside the shared value *) + if V.BorrowId.Set.mem original_bid bids then ( + set_ref (); + let bids' = V.BorrowId.Set.add new_bid bids in + V.SharedLoan (bids', sv)) + else super#visit_SharedLoan env bids sv + + method! visit_ASharedLoan env bids v av = + (* This case is similar to the {!SharedLoan} case *) + if V.BorrowId.Set.mem original_bid bids then ( + set_ref (); + let bids' = V.BorrowId.Set.add new_bid bids in + V.ASharedLoan (bids', v, av)) + else super#visit_ASharedLoan env bids v av + end + in + + let env = obj#visit_env () ctx.env in + (* Check that we reborrowed once *) + assert !r; + { ctx with env } + +(** Auxiliary function: see [end_borrow] *) +let give_back (config : C.config) (l : V.BorrowId.id) (bc : g_borrow_content) + (ctx : C.eval_ctx) : C.eval_ctx = + (* Debug *) + log#ldebug + (lazy + (let bc = + match bc with + | Concrete bc -> borrow_content_to_string ctx bc + | Abstract bc -> aborrow_content_to_string ctx bc + in + "give_back:\n- bid: " ^ V.BorrowId.to_string l ^ "\n- content: " ^ bc + ^ "\n- context:\n" ^ eval_ctx_to_string ctx ^ "\n")); + (* This is used for sanity checks *) + let sanity_ek = + { enter_shared_loans = true; enter_mut_borrows = true; enter_abs = true } + in + match bc with + | Concrete (V.MutBorrow (l', tv)) -> + (* Sanity check *) + assert (l' = l); + assert (not (loans_in_value tv)); + (* Check that the corresponding loan is somewhere - purely a sanity check *) + assert (Option.is_some (lookup_loan_opt sanity_ek l ctx)); + (* Update the context *) + give_back_value config l tv ctx + | Concrete (V.SharedBorrow (_, l') | V.InactivatedMutBorrow (_, l')) -> + (* Sanity check *) + assert (l' = l); + (* Check that the borrow is somewhere - purely a sanity check *) + assert (Option.is_some (lookup_loan_opt sanity_ek l ctx)); + (* Update the context *) + give_back_shared config l ctx + | Abstract (V.AMutBorrow (mv, l', av)) -> + (* Sanity check *) + assert (l' = l); + (* Check that the corresponding loan is somewhere - purely a sanity check *) + assert (Option.is_some (lookup_loan_opt sanity_ek l ctx)); + (* Update the context *) + give_back_avalue_to_same_abstraction config l mv av ctx + | Abstract (V.ASharedBorrow l') -> + (* Sanity check *) + assert (l' = l); + (* Check that the borrow is somewhere - purely a sanity check *) + assert (Option.is_some (lookup_loan_opt sanity_ek l ctx)); + (* Update the context *) + give_back_shared config l ctx + | Abstract (V.AProjSharedBorrow asb) -> + (* Sanity check *) + assert (borrow_in_asb l asb); + (* Update the context *) + give_back_shared config l ctx + | Abstract + ( V.AEndedMutBorrow _ | V.AIgnoredMutBorrow _ | V.AEndedIgnoredMutBorrow _ + | V.AEndedSharedBorrow ) -> + failwith "Unreachable" + +(** Convert an {!type:V.avalue} to a {!type:V.value}. + + This function is used when ending abstractions: whenever we end a borrow + in an abstraction, we converted the borrowed {!V.avalue} to a fresh symbolic + {!type:V.value}, then give back this {!type:V.value} to the context. + + Note that some regions may have ended in the symbolic value we generate. + For instance, consider the following function signature: + {[ + fn f<'a>(x : &'a mut &'a mut u32); + ]} + When ending the abstraction, the value given back for the outer borrow + should be ⊥. In practice, we will give back a symbolic value which can't + be expanded (because expanding this symbolic value would require expanding + a reference whose region has already ended). + *) +let convert_avalue_to_given_back_value (abs_kind : V.abs_kind) + (av : V.typed_avalue) : V.symbolic_value = + let sv_kind = + match abs_kind with + | V.FunCall -> V.FunCallGivenBack + | V.SynthRet -> V.SynthRetGivenBack + | V.SynthInput -> V.SynthInputGivenBack + in + mk_fresh_symbolic_value sv_kind av.V.ty + +(** End a borrow identified by its borrow id in a context. + + Rk.: from now onwards, the functions are written in continuation passing style. + The reason is that when ending borrows we may end abstractions, which results + in synthesized code. + + First lookup the borrow in the context and replace it with {!V.Bottom}. + Then, check that there is an associated loan in the context. When moving + values, before putting the value in its destination, we get an + intermediate state where some values are "outside" the context and thus + inaccessible. As {!give_back_value} just performs a map for instance (TODO: + not the case anymore), we need to check independently that there is indeed a + loan ready to receive the value we give back (note that we also have other + invariants like: there is exacly one mutable loan associated to a mutable + borrow, etc. but they are more easily maintained). + Note that in theory, we shouldn't never reach a problematic state as the + one we describe above, because when we move a value we need to end all the + loans inside before moving it. Still, it is a very useful sanity check. + Finally, give the values back. + + Of course, we end outer borrows before updating the target borrow if it + proves necessary. + If a borrow is inside an abstraction, we need to end the whole abstraction, + at the exception of the case where the loan corresponding to the borrow is + inside the same abstraction. We control this with the [allowed_abs] parameter: + if it is not [None], we allow ending a borrow if it is inside the given + abstraction. In practice, if the value is [Some abs_id], we should have + checked that the corresponding loan is inside the abstraction given by + [abs_id] before. In practice, only {!end_borrow} should call itself + with [allowed_abs = Some ...], all the other calls should use [allowed_abs = None]: + if you look ath the implementation details, [end_borrow] performs + all tne necessary checks in case a borrow is inside an abstraction. + TODO: we shouldn't allow this last case (end a borrow when the corresponding + loan is in the same abstraction). + + TODO: we should split this function in two: one function which doesn't + perform anything smart and is trusted, and another function for the + book-keeping. + *) +let rec end_borrow (config : C.config) (chain : borrow_or_abs_ids) + (allowed_abs : V.AbstractionId.id option) (l : V.BorrowId.id) : cm_fun = + fun cf ctx -> + (* Check that we don't loop *) + let chain0 = chain in + let chain = add_borrow_or_abs_id_to_chain "end_borrow: " (BorrowId l) chain in + log#ldebug + (lazy + ("end borrow: " ^ V.BorrowId.to_string l ^ ":\n- original context:\n" + ^ eval_ctx_to_string ctx)); + + (* Utility function for the sanity checks: check that the borrow disappeared + * from the context *) + let ctx0 = ctx in + let check_disappeared (ctx : C.eval_ctx) : unit = + let _ = + match lookup_borrow_opt ek_all l ctx with + | None -> () (* Ok *) + | Some _ -> + log#lerror + (lazy + ("end borrow: " ^ V.BorrowId.to_string l + ^ ": borrow didn't disappear:\n- original context:\n" + ^ eval_ctx_to_string ctx0 ^ "\n\n- new context:\n" + ^ eval_ctx_to_string ctx)); + failwith "Borrow not eliminated" + in + match lookup_loan_opt ek_all l ctx with + | None -> () (* Ok *) + | Some _ -> + log#lerror + (lazy + ("end borrow: " ^ V.BorrowId.to_string l + ^ ": loan didn't disappear:\n- original context:\n" + ^ eval_ctx_to_string ctx0 ^ "\n\n- new context:\n" + ^ eval_ctx_to_string ctx)); + failwith "Loan not eliminated" + in + let cf_check_disappeared : cm_fun = unit_to_cm_fun check_disappeared in + (* The complete sanity check: also check that after we ended a borrow, + * the invariant is preserved *) + let cf_check : cm_fun = + comp cf_check_disappeared (Invariants.cf_check_invariants config) + in + + (* Start by getting the borrow *) + match end_borrow_get_borrow allowed_abs l ctx with + (* Two cases: + * - error: we found outer borrows or inner loans (end them first) + * - success: we didn't find outer borrows when updating (but maybe we actually + didn't find the borrow we were looking for...) + *) + | Error priority -> ( + (* Debug *) + log#ldebug + (lazy + ("end borrow: " ^ V.BorrowId.to_string l + ^ ": found outer borrows/abs or inner loans:" + ^ show_priority_borrows_or_abs priority)); + (* End the priority borrows, abstraction, then try again to end the target + * borrow (if necessary) *) + match priority with + | OuterBorrows (Borrows bids) | InnerLoans (Borrows bids) -> + (* Note that we might get there with [allowed_abs <> None]: we might + * be trying to end a borrow inside an abstraction, but which is actually + * inside another borrow *) + let allowed_abs' = None in + (* End the outer borrows *) + let cc = end_borrows config chain allowed_abs' bids in + (* Retry to end the borrow *) + let cc = comp cc (end_borrow config chain0 allowed_abs l) in + (* Check and apply *) + comp cc cf_check cf ctx + | OuterBorrows (Borrow bid) | InnerLoans (Borrow bid) -> + let allowed_abs' = None in + (* End the outer borrow *) + let cc = end_borrow config chain allowed_abs' bid in + (* Retry to end the borrow *) + let cc = comp cc (end_borrow config chain0 allowed_abs l) in + (* Check and apply *) + comp cc cf_check cf ctx + | OuterAbs abs_id -> + (* The borrow is inside an asbtraction: check if the corresponding + * loan is inside the same abstraction. If this is the case, we end + * the borrow without ending the abstraction. If not, we need to + * end the whole abstraction *) + (* Note that we can lookup the loan anywhere *) + let ek = + { + enter_shared_loans = true; + enter_mut_borrows = true; + enter_abs = true; + } + in + let cf_end_abs : cm_fun = + match lookup_loan ek l ctx with + | AbsId loan_abs_id, _ -> + if loan_abs_id = abs_id then + (* Same abstraction! We can end the borrow *) + end_borrow config chain0 (Some abs_id) l + else + (* Not the same abstraction: we need to end the whole abstraction. + * By doing that we should have ended the target borrow (see the + * below sanity check) *) + end_abstraction config chain abs_id + | VarId _, _ -> + (* The loan is not inside the same abstraction (actually inside + * a non-abstraction value): we need to end the whole abstraction *) + end_abstraction config chain abs_id + in + (* Compose with a sanity check *) + comp cf_end_abs cf_check cf ctx) + | Ok (ctx, None) -> + log#ldebug (lazy "End borrow: borrow not found"); + (* It is possible that we can't find a borrow in symbolic mode (ending + * an abstraction may end several borrows at once *) + assert (config.mode = SymbolicMode); + (* Do a sanity check and continue *) + cf_check cf ctx + (* We found a borrow: give it back (i.e., update the corresponding loan) *) + | Ok (ctx, Some bc) -> + (* Sanity check: the borrowed value shouldn't contain loans *) + (match bc with + | Concrete (V.MutBorrow (_, bv)) -> + assert (Option.is_none (get_first_loan_in_value bv)) + | _ -> ()); + (* Give back the value *) + let ctx = give_back config l bc ctx in + (* Do a sanity check and continue *) + cf_check cf ctx + +and end_borrows (config : C.config) (chain : borrow_or_abs_ids) + (allowed_abs : V.AbstractionId.id option) (lset : V.BorrowId.Set.t) : cm_fun + = + fun cf -> + (* This is not necessary, but we prefer to reorder the borrow ids, + * so that we actually end from the smallest id to the highest id - just + * a matter of taste, and may make debugging easier *) + let ids = V.BorrowId.Set.fold (fun id ids -> id :: ids) lset [] in + List.fold_left (fun cf id -> end_borrow config chain allowed_abs id cf) cf ids + +and end_abstraction (config : C.config) (chain : borrow_or_abs_ids) + (abs_id : V.AbstractionId.id) : cm_fun = + fun cf ctx -> + (* Check that we don't loop *) + let chain = + add_borrow_or_abs_id_to_chain "end_abstraction: " (AbsId abs_id) chain + in + (* Remember the original context for printing purposes *) + let ctx0 = ctx in + log#ldebug + (lazy + ("end_abstraction: " + ^ V.AbstractionId.to_string abs_id + ^ "\n- original context:\n" ^ eval_ctx_to_string ctx0)); + + (* Lookup the abstraction *) + let abs = C.ctx_lookup_abs ctx abs_id in + + (* Check that we can end the abstraction *) + assert abs.can_end; + + (* End the parent abstractions first *) + let cc = end_abstractions config chain abs.parents in + let cc = + comp_unit cc (fun ctx -> + log#ldebug + (lazy + ("end_abstraction: " + ^ V.AbstractionId.to_string abs_id + ^ "\n- context after parent abstractions ended:\n" + ^ eval_ctx_to_string ctx))) + in + + (* End the loans inside the abstraction *) + let cc = comp cc (end_abstraction_loans config chain abs_id) in + let cc = + comp_unit cc (fun ctx -> + log#ldebug + (lazy + ("end_abstraction: " + ^ V.AbstractionId.to_string abs_id + ^ "\n- context after loans ended:\n" ^ eval_ctx_to_string ctx))) + in + + (* End the abstraction itself by redistributing the borrows it contains *) + let cc = comp cc (end_abstraction_borrows config chain abs_id) in + + (* End the regions owned by the abstraction - note that we don't need to + * relookup the abstraction: the set of regions in an abstraction never + * changes... *) + let cc = + comp_update cc (fun ctx -> + let ended_regions = + T.RegionId.Set.union ctx.ended_regions abs.V.regions + in + { ctx with ended_regions }) + in + + (* Remove all the references to the id of the current abstraction, and remove + * the abstraction itself. + * **Rk.**: this is where we synthesize the updated symbolic AST *) + let cc = comp cc (end_abstraction_remove_from_context config abs_id) in + + (* Debugging *) + let cc = + comp_unit cc (fun ctx -> + log#ldebug + (lazy + ("end_abstraction: " + ^ V.AbstractionId.to_string abs_id + ^ "\n- original context:\n" ^ eval_ctx_to_string ctx0 + ^ "\n\n- new context:\n" ^ eval_ctx_to_string ctx))) + in + + (* Sanity check: ending an abstraction must preserve the invariants *) + let cc = comp cc (Invariants.cf_check_invariants config) in + + (* Apply the continuation *) + cc cf ctx + +and end_abstractions (config : C.config) (chain : borrow_or_abs_ids) + (abs_ids : V.AbstractionId.Set.t) : cm_fun = + fun cf -> + (* This is not necessary, but we prefer to reorder the abstraction ids, + * so that we actually end from the smallest id to the highest id - just + * a matter of taste, and may make debugging easier *) + let abs_ids = V.AbstractionId.Set.fold (fun id ids -> id :: ids) abs_ids [] in + List.fold_left (fun cf id -> end_abstraction config chain id cf) cf abs_ids + +and end_abstraction_loans (config : C.config) (chain : borrow_or_abs_ids) + (abs_id : V.AbstractionId.id) : cm_fun = + fun cf ctx -> + (* Lookup the abstraction *) + let abs = C.ctx_lookup_abs ctx abs_id in + (* End the first loan we find. + * + * We ignore the "ignored mut/shared loans": as we should have already ended + * the parent abstractions, they necessarily come from children. *) + let opt_loan = get_first_non_ignored_aloan_in_abstraction abs in + match opt_loan with + | None -> + (* No loans: nothing to update *) + cf ctx + | Some (BorrowIds bids) -> + (* There are loans: end the corresponding borrows, then recheck *) + let cc : cm_fun = + match bids with + | Borrow bid -> end_borrow config chain None bid + | Borrows bids -> end_borrows config chain None bids + in + (* Reexplore, looking for loans *) + let cc = comp cc (end_abstraction_loans config chain abs_id) in + (* Continue *) + cc cf ctx + | Some (SymbolicValue sv) -> + (* There is a proj_loans over a symbolic value: end the proj_borrows + * which intersect this proj_loans, then end the proj_loans itself *) + let cc = end_proj_loans_symbolic config chain abs_id abs.regions sv in + (* Reexplore, looking for loans *) + let cc = comp cc (end_abstraction_loans config chain abs_id) in + (* Continue *) + cc cf ctx + +and end_abstraction_borrows (config : C.config) (chain : borrow_or_abs_ids) + (abs_id : V.AbstractionId.id) : cm_fun = + fun cf ctx -> + log#ldebug + (lazy + ("end_abstraction_borrows: abs_id: " ^ V.AbstractionId.to_string abs_id)); + (* Note that the abstraction mustn't contain any loans *) + (* We end the borrows, starting with the *inner* ones. This is important + when considering nested borrows which have the same lifetime. + TODO: is that really important? Initially, there was a concern about + whether we should give back ⊥ or not, but everything is handled by + the symbolic value expansion... Also, now we use the AEndedMutBorrow + values to store the children avalues (which was not the case before - we + initially replaced the ended mut borrows with ⊥). + *) + (* We explore in-depth and use exceptions. When exploring a borrow, if + * the exploration didn't trigger an exception, it means there are no + * inner borrows to end: we can thus trigger an exception for the current + * borrow. *) + let obj = + object + inherit [_] V.iter_abs as super + + method! visit_aborrow_content env bc = + (* In-depth exploration *) + super#visit_aborrow_content env bc; + (* No exception was raise: we can raise an exception for the + * current borrow *) + match bc with + | V.AMutBorrow (_, _, _) | V.ASharedBorrow _ -> + (* Raise an exception *) + raise (FoundABorrowContent bc) + | V.AProjSharedBorrow asb -> + (* Raise an exception only if the asb contains borrows *) + if + List.exists + (fun x -> match x with V.AsbBorrow _ -> true | _ -> false) + asb + then raise (FoundABorrowContent bc) + else () + | V.AEndedMutBorrow _ | V.AIgnoredMutBorrow _ + | V.AEndedIgnoredMutBorrow _ | V.AEndedSharedBorrow -> + (* Nothing to do for ignored borrows *) + () + + method! visit_aproj env sproj = + (match sproj with + | V.AProjLoans _ -> failwith "Unexpected" + | V.AProjBorrows (sv, proj_ty) -> + raise (FoundAProjBorrows (sv, proj_ty)) + | V.AEndedProjLoans _ | V.AEndedProjBorrows _ | V.AIgnoredProjBorrows -> + ()); + super#visit_aproj env sproj + + (** We may need to end borrows in "regular" values, because of shared values *) + method! visit_borrow_content _ bc = + match bc with + | V.SharedBorrow (_, _) | V.MutBorrow (_, _) -> + raise (FoundBorrowContent bc) + | V.InactivatedMutBorrow _ -> failwith "Unreachable" + end + in + (* Lookup the abstraction *) + let abs = C.ctx_lookup_abs ctx abs_id in + try + (* Explore the abstraction, looking for borrows *) + obj#visit_abs () abs; + (* No borrows: nothing to update *) + cf ctx + with + (* There are concrete (i.e., not symbolic) borrows: end them, then reexplore *) + | FoundABorrowContent bc -> + log#ldebug + (lazy + ("end_abstraction_borrows: found aborrow content: " + ^ aborrow_content_to_string ctx bc)); + let ctx = + match bc with + | V.AMutBorrow (_mv, bid, av) -> + (* First, convert the avalue to a (fresh symbolic) value *) + let sv = convert_avalue_to_given_back_value abs.kind av in + (* Replace the mut borrow to register the fact that we ended + * it and store with it the freshly generated given back value *) + let ended_borrow = V.ABorrow (V.AEndedMutBorrow (sv, av)) in + let ctx = update_aborrow ek_all bid ended_borrow ctx in + (* Give the value back *) + let sv = mk_typed_value_from_symbolic_value sv in + give_back_value config bid sv ctx + | V.ASharedBorrow bid -> + (* Replace the shared borrow to account for the fact it ended *) + let ended_borrow = V.ABorrow V.AEndedSharedBorrow in + let ctx = update_aborrow ek_all bid ended_borrow ctx in + (* Give back *) + give_back_shared config bid ctx + | V.AProjSharedBorrow asb -> + (* Retrieve the borrow ids *) + let bids = + List.filter_map + (fun asb -> + match asb with + | V.AsbBorrow bid -> Some bid + | V.AsbProjReborrows (_, _) -> None) + asb + in + (* There should be at least one borrow identifier in the set, which we + * can use to identify the whole set *) + let repr_bid = List.hd bids in + (* Replace the shared borrow with Bottom *) + let ctx = update_aborrow ek_all repr_bid V.ABottom ctx in + (* Give back the shared borrows *) + let ctx = + List.fold_left + (fun ctx bid -> give_back_shared config bid ctx) + ctx bids + in + (* Continue *) + ctx + | V.AEndedMutBorrow _ | V.AIgnoredMutBorrow _ + | V.AEndedIgnoredMutBorrow _ | V.AEndedSharedBorrow -> + failwith "Unexpected" + in + (* Reexplore *) + end_abstraction_borrows config chain abs_id cf ctx + (* There are symbolic borrows: end them, then reexplore *) + | FoundAProjBorrows (sv, proj_ty) -> + log#ldebug + (lazy + ("end_abstraction_borrows: found aproj borrows: " + ^ aproj_to_string ctx (V.AProjBorrows (sv, proj_ty)))); + (* Generate a fresh symbolic value *) + let nsv = mk_fresh_symbolic_value V.FunCallGivenBack proj_ty in + (* Replace the proj_borrows - there should be exactly one *) + let ended_borrow = V.AEndedProjBorrows nsv in + let ctx = update_aproj_borrows abs.abs_id sv ended_borrow ctx in + (* Give back the symbolic value *) + let ctx = + give_back_symbolic_value config abs.regions proj_ty sv nsv ctx + in + (* Reexplore *) + end_abstraction_borrows config chain abs_id cf ctx + (* There are concrete (i.e., not symbolic) borrows in shared values: end them, then reexplore *) + | FoundBorrowContent bc -> + log#ldebug + (lazy + ("end_abstraction_borrows: found borrow content: " + ^ borrow_content_to_string ctx bc)); + let ctx = + match bc with + | V.SharedBorrow (_, bid) -> ( + (* Replace the shared borrow with bottom *) + match end_borrow_get_borrow (Some abs_id) bid ctx with + | Error _ -> failwith "Unreachable" + | Ok (ctx, _) -> + (* Give back *) + give_back_shared config bid ctx) + | V.MutBorrow (bid, v) -> ( + (* Replace the mut borrow with bottom *) + match end_borrow_get_borrow (Some abs_id) bid ctx with + | Error _ -> failwith "Unreachable" + | Ok (ctx, _) -> + (* Give the value back - note that the mut borrow was below a + * shared borrow: the value is thus unchanged *) + give_back_value config bid v ctx) + | V.InactivatedMutBorrow _ -> failwith "Unreachable" + in + (* Reexplore *) + end_abstraction_borrows config chain abs_id cf ctx + +(** Remove an abstraction from the context, as well as all its references *) +and end_abstraction_remove_from_context (_config : C.config) + (abs_id : V.AbstractionId.id) : cm_fun = + fun cf ctx -> + let rec remove_from_env (env : C.env) : C.env * V.abs option = + match env with + | [] -> failwith "Unreachable" + | C.Frame :: _ -> (env, None) + | Var (bv, v) :: env -> + let env, abs_opt = remove_from_env env in + (Var (bv, v) :: env, abs_opt) + | C.Abs abs :: env -> + if abs.abs_id = abs_id then (env, Some abs) + else + let env, abs_opt = remove_from_env env in + let parents = V.AbstractionId.Set.remove abs_id abs.parents in + (C.Abs { abs with V.parents } :: env, abs_opt) + in + let env, abs = remove_from_env ctx.C.env in + let ctx = { ctx with C.env } in + let abs = Option.get abs in + (* Apply the continuation *) + let expr = cf ctx in + (* Synthesize the symbolic AST *) + S.synthesize_end_abstraction abs expr + +(** End a proj_loan over a symbolic value by ending the proj_borrows which + intersect this proj_loans. + + Rk.: + - if this symbolic value is primitively copiable, then: + - either proj_borrows are only present in the concrete context + - or there is only one intersecting proj_borrow present in an + abstraction + - otherwise, this symbolic value is not primitively copiable: + - there may be proj_borrows_shared over this value + - if we put aside the proj_borrows_shared, there should be exactly one + intersecting proj_borrows, either in the concrete context or in an + abstraction +*) +and end_proj_loans_symbolic (config : C.config) (chain : borrow_or_abs_ids) + (abs_id : V.AbstractionId.id) (regions : T.RegionId.Set.t) + (sv : V.symbolic_value) : cm_fun = + fun cf ctx -> + (* Small helpers for sanity checks *) + let check ctx = no_aproj_over_symbolic_in_context sv ctx in + let cf_check (cf : m_fun) : m_fun = + fun ctx -> + check ctx; + cf ctx + in + (* Find the first proj_borrows which intersects the proj_loans *) + let explore_shared = true in + match lookup_intersecting_aproj_borrows_opt explore_shared regions sv ctx with + | None -> + (* We couldn't find any in the context: it means that the symbolic value + * is in the concrete environment (or that we dropped it, in which case + * it is completely absent). We thus simply need to replace the loans + * projector with an ended projector. *) + let ctx = update_aproj_loans_to_ended abs_id sv ctx in + (* Sanity check *) + check ctx; + (* Continue *) + cf ctx + | Some (SharedProjs projs) -> + (* We found projectors over shared values - split between the projectors + which belong to the current abstraction and the others. + The context looks like this: + {[ + abs'0 { + // The loan was initially like this: + // [shared_loan lids (s <: ...) [s]] + // but if we get there it means it was already ended: + ended_shared_loan (s <: ...) [s] + proj_shared_borrows [...; (s <: ...); ...] + proj_shared_borrows [...; (s <: ...); ...] + ... + } + + abs'1 [ + proj_shared_borrows [...; (s <: ...); ...] + ... + } + + ... + + // No [s] outside of abstractions + + ]} + *) + let _owned_projs, external_projs = + List.partition (fun (abs_id', _) -> abs_id' = abs_id) projs + in + (* End the external borrow projectors (end their abstractions) *) + let cf_end_external : cm_fun = + fun cf ctx -> + let abs_ids = List.map fst external_projs in + let abs_ids = + List.fold_left + (fun s id -> V.AbstractionId.Set.add id s) + V.AbstractionId.Set.empty abs_ids + in + (* End the abstractions and continue *) + end_abstractions config chain abs_ids cf ctx + in + (* End the internal borrows projectors and the loans projector *) + let cf_end_internal : cm_fun = + fun cf ctx -> + (* All the proj_borrows are owned: simply erase them *) + let ctx = remove_intersecting_aproj_borrows_shared regions sv ctx in + (* End the loan itself *) + let ctx = update_aproj_loans_to_ended abs_id sv ctx in + (* Sanity check *) + check ctx; + (* Continue *) + cf ctx + in + (* Compose and apply *) + let cc = comp cf_end_external cf_end_internal in + cc cf ctx + | Some (NonSharedProj (abs_id', _proj_ty)) -> + (* We found one projector of borrows in an abstraction: if it comes + * from this abstraction, we can end it directly, otherwise we need + * to end the abstraction where it came from first *) + if abs_id' = abs_id then ( + (* Note that it happens when a function returns a [&mut ...] which gets + expanded to [mut_borrow l s], and we end the borrow [l] (so [s] gets + reinjected in the parent abstraction without having been modified). + + The context looks like this: + {[ + abs'0 { + [s <: ...] + (s <: ...) + } + + // Note that [s] can't appear in other abstractions or in the + // regular environment (because we forbid the duplication of + // symbolic values which contain borrows). + ]} + *) + (* End the projector of borrows - TODO: not completely sure what to + * replace it with... Maybe we should introduce an ABottomProj? *) + let ctx = update_aproj_borrows abs_id sv V.AIgnoredProjBorrows ctx in + (* Sanity check: no other occurrence of an intersecting projector of borrows *) + assert ( + Option.is_none + (lookup_intersecting_aproj_borrows_opt explore_shared regions sv ctx)); + (* End the projector of loans *) + let ctx = update_aproj_loans_to_ended abs_id sv ctx in + (* Sanity check *) + check ctx; + (* Continue *) + cf ctx) + else + (* The borrows proj comes from a different abstraction: end it. *) + let cc = end_abstraction config chain abs_id' in + (* Retry ending the projector of loans *) + let cc = + comp cc (end_proj_loans_symbolic config chain abs_id regions sv) + in + (* Sanity check *) + let cc = comp cc cf_check in + (* Continue *) + cc cf ctx + +let end_outer_borrow config : V.BorrowId.id -> cm_fun = + end_borrow config [] None + +let end_outer_borrows config : V.BorrowId.Set.t -> cm_fun = + end_borrows config [] None + +(** Helper function: see [activate_inactivated_mut_borrow]. + + This function updates the shared loan to a mutable loan (we then update + the borrow with another helper). Of course, the shared loan must contain + exactly one borrow id (the one we give as parameter), otherwise we can't + promote it. Also, the shared value mustn't contain any loan. + + The returned value (previously shared) is checked: + - it mustn't contain loans + - it mustn't contain {!V.Bottom} + - it mustn't contain inactivated borrows + TODO: this kind of checks should be put in an auxiliary helper, because + they are redundant. + + The loan to update mustn't be a borrowed value. + *) +let promote_shared_loan_to_mut_loan (l : V.BorrowId.id) + (cf : V.typed_value -> m_fun) : m_fun = + fun ctx -> + (* Debug *) + log#ldebug + (lazy + ("promote_shared_loan_to_mut_loan:\n- loan: " ^ V.BorrowId.to_string l + ^ "\n- context:\n" ^ eval_ctx_to_string ctx ^ "\n")); + (* Lookup the shared loan - note that we can't promote a shared loan + * in a shared value, but we can do it in a mutably borrowed value. + * This is important because we can do: [let y = &two-phase ( *x );] + *) + let ek = + { enter_shared_loans = false; enter_mut_borrows = true; enter_abs = false } + in + match lookup_loan ek l ctx with + | _, Concrete (V.MutLoan _) -> + failwith "Expected a shared loan, found a mut loan" + | _, Concrete (V.SharedLoan (bids, sv)) -> + (* Check that there is only one borrow id (l) and update the loan *) + assert (V.BorrowId.Set.mem l bids && V.BorrowId.Set.cardinal bids = 1); + (* We need to check that there aren't any loans in the value: + we should have gotten rid of those already, but it is better + to do a sanity check. *) + assert (not (loans_in_value sv)); + (* Check there isn't {!Bottom} (this is actually an invariant *) + assert (not (bottom_in_value ctx.ended_regions sv)); + (* Check there aren't inactivated borrows *) + assert (not (inactivated_in_value sv)); + (* Update the loan content *) + let ctx = update_loan ek l (V.MutLoan l) ctx in + (* Continue *) + cf sv ctx + | _, Abstract _ -> + (* I don't think it is possible to have two-phase borrows involving borrows + * returned by abstractions. I'm not sure how we could handle that anyway. *) + failwith + "Can't promote a shared loan to a mutable loan if the loan is inside \ + an abstraction" + +(** Helper function: see {!activate_inactivated_mut_borrow}. + + This function updates a shared borrow to a mutable borrow. + *) +let promote_inactivated_borrow_to_mut_borrow (l : V.BorrowId.id) (cf : m_fun) + (borrowed_value : V.typed_value) : m_fun = + fun ctx -> + (* Lookup the inactivated borrow - note that we don't go inside borrows/loans: + there can't be inactivated borrows inside other borrows/loans + *) + let ek = + { enter_shared_loans = false; enter_mut_borrows = false; enter_abs = false } + in + let ctx = + match lookup_borrow ek l ctx with + | Concrete (V.SharedBorrow _ | V.MutBorrow (_, _)) -> + failwith "Expected an inactivated mutable borrow" + | Concrete (V.InactivatedMutBorrow _) -> + (* Update it *) + update_borrow ek l (V.MutBorrow (l, borrowed_value)) ctx + | Abstract _ -> + (* This can't happen for sure *) + failwith + "Can't promote a shared borrow to a mutable borrow if the borrow is \ + inside an abstraction" + in + (* Continue *) + cf ctx + +(** Promote an inactivated mut borrow to a mut borrow. + + The borrow must point to a shared value which is borrowed exactly once. + *) +let rec activate_inactivated_mut_borrow (config : C.config) (l : V.BorrowId.id) + : cm_fun = + fun cf ctx -> + (* Lookup the value *) + let ek = + { enter_shared_loans = false; enter_mut_borrows = true; enter_abs = false } + in + match lookup_loan ek l ctx with + | _, Concrete (V.MutLoan _) -> failwith "Unreachable" + | _, Concrete (V.SharedLoan (bids, sv)) -> ( + (* If there are loans inside the value, end them. Note that there can't be + inactivated borrows inside the value. + If we perform an update, do a recursive call to lookup the updated value *) + match get_first_loan_in_value sv with + | Some lc -> + (* End the loans *) + let cc = + match lc with + | V.SharedLoan (bids, _) -> end_outer_borrows config bids + | V.MutLoan bid -> end_outer_borrow config bid + in + (* Recursive call *) + let cc = comp cc (activate_inactivated_mut_borrow config l) in + (* Continue *) + cc cf ctx + | None -> + (* No loan to end inside the value *) + (* Some sanity checks *) + log#ldebug + (lazy + ("activate_inactivated_mut_borrow: resulting value:\n" + ^ typed_value_to_string ctx sv)); + assert (not (loans_in_value sv)); + assert (not (bottom_in_value ctx.ended_regions sv)); + assert (not (inactivated_in_value sv)); + (* End the borrows which borrow from the value, at the exception of + the borrow we want to promote *) + let bids = V.BorrowId.Set.remove l bids in + let cc = end_outer_borrows config bids in + (* Promote the loan - TODO: this will fail if the value contains + * any loans. In practice, it shouldn't, but we could also + * look for loans inside the value and end them before promoting + * the borrow. *) + let cc = comp cc (promote_shared_loan_to_mut_loan l) in + (* Promote the borrow - the value should have been checked by + {!promote_shared_loan_to_mut_loan} + *) + let cc = + comp cc (fun cf borrowed_value -> + promote_inactivated_borrow_to_mut_borrow l cf borrowed_value) + in + (* Continue *) + cc cf ctx) + | _, Abstract _ -> + (* I don't think it is possible to have two-phase borrows involving borrows + * returned by abstractions. I'm not sure how we could handle that anyway. *) + failwith + "Can't activate an inactivated mutable borrow referencing a loan inside\n\ + \ an abstraction" diff --git a/compiler/InterpreterBorrowsCore.ml b/compiler/InterpreterBorrowsCore.ml new file mode 100644 index 00000000..a5501712 --- /dev/null +++ b/compiler/InterpreterBorrowsCore.ml @@ -0,0 +1,1181 @@ +(* This file defines the basic blocks to implement the semantics of borrows. + * Note that those functions are not only used in InterpreterBorrows, but + * also in Invariants or InterpreterProjectors *) + +module T = Types +module V = Values +module C = Contexts +module Subst = Substitute +module L = Logging +open Utils +open TypesUtils +open InterpreterUtils + +(** The local logger *) +let log = L.borrows_log + +(** TODO: cleanup this a bit, once we have a better understanding about + what we need. + TODO: I'm not sure in which file this should be moved... *) +type exploration_kind = { + enter_shared_loans : bool; + enter_mut_borrows : bool; + enter_abs : bool; + (** Note that if we allow to enter abs, we don't check whether we enter + mutable/shared loans or borrows: there are no use cases requiring + a finer control. *) +} +(** This record controls how some generic helper lookup/update + functions behave, by restraining the kind of therms they can enter. +*) + +let ek_all : exploration_kind = + { enter_shared_loans = true; enter_mut_borrows = true; enter_abs = true } + +type borrow_ids = Borrows of V.BorrowId.Set.t | Borrow of V.BorrowId.id +[@@deriving show] + +exception FoundBorrowIds of borrow_ids + +type priority_borrows_or_abs = + | OuterBorrows of borrow_ids + | OuterAbs of V.AbstractionId.id + | InnerLoans of borrow_ids +[@@deriving show] + +type borrow_ids_or_symbolic_value = + | BorrowIds of borrow_ids + | SymbolicValue of V.symbolic_value +[@@deriving show] + +let update_if_none opt x = match opt with None -> Some x | _ -> opt + +(** Utility exception *) +exception FoundPriority of priority_borrows_or_abs + +type loan_or_borrow_content = + | LoanContent of V.loan_content + | BorrowContent of V.borrow_content +[@@deriving show] + +type borrow_or_abs_id = + | BorrowId of V.BorrowId.id + | AbsId of V.AbstractionId.id + +type borrow_or_abs_ids = borrow_or_abs_id list + +let borrow_or_abs_id_to_string (id : borrow_or_abs_id) : string = + match id with + | AbsId id -> "abs@" ^ V.AbstractionId.to_string id + | BorrowId id -> "l@" ^ V.BorrowId.to_string id + +let borrow_or_abs_ids_chain_to_string (ids : borrow_or_abs_ids) : string = + let ids = List.rev ids in + let ids = List.map borrow_or_abs_id_to_string ids in + String.concat " -> " ids + +(** Add a borrow or abs id to a chain of ids, while checking that we don't loop *) +let add_borrow_or_abs_id_to_chain (msg : string) (id : borrow_or_abs_id) + (ids : borrow_or_abs_ids) : borrow_or_abs_ids = + if List.mem id ids then + failwith + (msg ^ "detected a loop in the chain of ids: " + ^ borrow_or_abs_ids_chain_to_string (id :: ids)) + else id :: ids + +(** Helper function. + + This function allows to define in a generic way a comparison of region types. + See [projections_interesect] for instance. + + [default]: default boolean to return, when comparing types with no regions + [combine]: how to combine booleans + [compare_regions]: how to compare regions + *) +let rec compare_rtys (default : bool) (combine : bool -> bool -> bool) + (compare_regions : T.RegionId.id T.region -> T.RegionId.id T.region -> bool) + (ty1 : T.rty) (ty2 : T.rty) : bool = + let compare = compare_rtys default combine compare_regions in + match (ty1, ty2) with + | T.Bool, T.Bool | T.Char, T.Char | T.Str, T.Str -> default + | T.Integer int_ty1, T.Integer int_ty2 -> + assert (int_ty1 = int_ty2); + default + | T.Adt (id1, regions1, tys1), T.Adt (id2, regions2, tys2) -> + assert (id1 = id2); + + (* The check for the ADTs is very crude: we simply compare the arguments + * two by two. + * + * For instance, when checking if some projections intersect, we simply + * check if some arguments intersect. As all the type and region + * parameters should be used somewhere in the ADT (otherwise rustc + * generates an error), it means that it should be equivalent to checking + * whether two fields intersect (and anyway comparing the field types is + * difficult in case of enumerations...). + * If we didn't have the above property enforced by the rust compiler, + * this check would still be a reasonable conservative approximation. *) + + (* Check the region parameters *) + let regions = List.combine regions1 regions2 in + let params_b = + List.fold_left + (fun b (r1, r2) -> combine b (compare_regions r1 r2)) + default regions + in + (* Check the type parameters *) + let tys = List.combine tys1 tys2 in + let tys_b = + List.fold_left + (fun b (ty1, ty2) -> combine b (compare ty1 ty2)) + default tys + in + (* Combine *) + combine params_b tys_b + | T.Array ty1, T.Array ty2 | T.Slice ty1, T.Slice ty2 -> compare ty1 ty2 + | T.Ref (r1, ty1, kind1), T.Ref (r2, ty2, kind2) -> + (* Sanity check *) + assert (kind1 = kind2); + (* Explanation for the case where we check if projections intersect: + * the projections intersect if the borrows intersect or their contents + * intersect. *) + let regions_b = compare_regions r1 r2 in + let tys_b = compare ty1 ty2 in + combine regions_b tys_b + | T.TypeVar id1, T.TypeVar id2 -> + assert (id1 = id2); + default + | _ -> + log#lerror + (lazy + ("compare_rtys: unexpected inputs:" ^ "\n- ty1: " ^ T.show_rty ty1 + ^ "\n- ty2: " ^ T.show_rty ty2)); + failwith "Unreachable" + +(** Check if two different projections intersect. This is necessary when + giving a symbolic value to an abstraction: we need to check that + the regions which are already ended inside the abstraction don't + intersect the regions over which we project in the new abstraction. + Note that the two abstractions have different views (in terms of regions) + of the symbolic value (hence the two region types). +*) +let projections_intersect (ty1 : T.rty) (rset1 : T.RegionId.Set.t) (ty2 : T.rty) + (rset2 : T.RegionId.Set.t) : bool = + let default = false in + let combine b1 b2 = b1 || b2 in + let compare_regions r1 r2 = + region_in_set r1 rset1 && region_in_set r2 rset2 + in + compare_rtys default combine compare_regions ty1 ty2 + +(** Check if the first projection contains the second projection. + We use this function when checking invariants. +*) +let projection_contains (ty1 : T.rty) (rset1 : T.RegionId.Set.t) (ty2 : T.rty) + (rset2 : T.RegionId.Set.t) : bool = + let default = true in + let combine b1 b2 = b1 && b2 in + let compare_regions r1 r2 = + region_in_set r1 rset1 || not (region_in_set r2 rset2) + in + compare_rtys default combine compare_regions ty1 ty2 + +(** Lookup a loan content. + + The loan is referred to by a borrow id. + + TODO: group abs_or_var_id and g_loan_content. + *) +let lookup_loan_opt (ek : exploration_kind) (l : V.BorrowId.id) + (ctx : C.eval_ctx) : (abs_or_var_id * g_loan_content) option = + (* We store here whether we are inside an abstraction or a value - note that we + * could also track that with the environment, it would probably be more idiomatic + * and cleaner *) + let abs_or_var : abs_or_var_id option ref = ref None in + + let obj = + object + inherit [_] C.iter_eval_ctx as super + + method! visit_borrow_content env bc = + match bc with + | V.SharedBorrow (mv, bid) -> + (* Nothing specific to do *) + super#visit_SharedBorrow env mv bid + | V.InactivatedMutBorrow (mv, bid) -> + (* Nothing specific to do *) + super#visit_InactivatedMutBorrow env mv bid + | V.MutBorrow (bid, mv) -> + (* Control the dive *) + if ek.enter_mut_borrows then super#visit_MutBorrow env bid mv + else () + + (** We reimplement {!visit_Loan} (rather than the more precise functions + {!visit_SharedLoan}, etc.) on purpose: as we have an exhaustive match + below, we are more resilient to definition updates (the compiler + is our friend). + *) + method! visit_loan_content env lc = + match lc with + | V.SharedLoan (bids, sv) -> + (* Check if this is the loan we are looking for, and control the dive *) + if V.BorrowId.Set.mem l bids then + raise (FoundGLoanContent (Concrete lc)) + else if ek.enter_shared_loans then + super#visit_SharedLoan env bids sv + else () + | V.MutLoan bid -> + (* Check if this is the loan we are looking for *) + if bid = l then raise (FoundGLoanContent (Concrete lc)) + else super#visit_MutLoan env bid + + (** Note that we don't control diving inside the abstractions: if we + allow to dive inside abstractions, we allow to go anywhere + (because there are no use cases requiring finer control) *) + method! visit_aloan_content env lc = + match lc with + | V.AMutLoan (bid, av) -> + if bid = l then raise (FoundGLoanContent (Abstract lc)) + else super#visit_AMutLoan env bid av + | V.ASharedLoan (bids, v, av) -> + if V.BorrowId.Set.mem l bids then + raise (FoundGLoanContent (Abstract lc)) + else super#visit_ASharedLoan env bids v av + | V.AEndedMutLoan { given_back = _; child = _; given_back_meta = _ } + | V.AEndedSharedLoan (_, _) + | V.AIgnoredMutLoan (_, _) + | V.AEndedIgnoredMutLoan + { given_back = _; child = _; given_back_meta = _ } + | V.AIgnoredSharedLoan _ -> + super#visit_aloan_content env lc + + method! visit_Var env bv v = + assert (Option.is_none !abs_or_var); + abs_or_var := + Some + (VarId (match bv with Some bv -> Some bv.C.index | None -> None)); + super#visit_Var env bv v; + abs_or_var := None + + method! visit_Abs env abs = + assert (Option.is_none !abs_or_var); + if ek.enter_abs then ( + abs_or_var := Some (AbsId abs.V.abs_id); + super#visit_Abs env abs; + abs_or_var := None) + else () + end + in + (* We use exceptions *) + try + obj#visit_eval_ctx () ctx; + None + with FoundGLoanContent lc -> ( + match !abs_or_var with + | Some abs_or_var -> Some (abs_or_var, lc) + | None -> raise (Failure "Inconsistent state")) + +(** Lookup a loan content. + + The loan is referred to by a borrow id. + Raises an exception if no loan was found. + *) +let lookup_loan (ek : exploration_kind) (l : V.BorrowId.id) (ctx : C.eval_ctx) : + abs_or_var_id * g_loan_content = + match lookup_loan_opt ek l ctx with + | None -> failwith "Unreachable" + | Some res -> res + +(** Update a loan content. + + The loan is referred to by a borrow id. + + This is a helper function: it might break invariants. + *) +let update_loan (ek : exploration_kind) (l : V.BorrowId.id) + (nlc : V.loan_content) (ctx : C.eval_ctx) : C.eval_ctx = + (* We use a reference to check that we update exactly one loan: when updating + * inside values, we check we don't update more than one loan. Then, upon + * returning we check that we updated at least once. *) + let r = ref false in + let update () : V.loan_content = + assert (not !r); + r := true; + nlc + in + + let obj = + object + inherit [_] C.map_eval_ctx as super + + method! visit_borrow_content env bc = + match bc with + | V.SharedBorrow (_, _) | V.InactivatedMutBorrow _ -> + (* Nothing specific to do *) + super#visit_borrow_content env bc + | V.MutBorrow (bid, mv) -> + (* Control the dive into mutable borrows *) + if ek.enter_mut_borrows then super#visit_MutBorrow env bid mv + else V.MutBorrow (bid, mv) + + (** We reimplement {!visit_loan_content} (rather than one of the sub- + functions) on purpose: exhaustive matches are good for maintenance *) + method! visit_loan_content env lc = + match lc with + | V.SharedLoan (bids, sv) -> + (* Shared loan: check if this is the loan we are looking for, and + control the dive. *) + if V.BorrowId.Set.mem l bids then update () + else if ek.enter_shared_loans then + super#visit_SharedLoan env bids sv + else V.SharedLoan (bids, sv) + | V.MutLoan bid -> + (* Mut loan: checks if this is the loan we are looking for *) + if bid = l then update () else super#visit_MutLoan env bid + + (** Note that once inside the abstractions, we don't control diving + (there are no use cases requiring finer control). + Also, as we give back a {!loan_content} (and not an {!aloan_content}) + we don't need to do reimplement the visit functions for the values + inside the abstractions (rk.: there may be "concrete" values inside + abstractions, so there is a utility in diving inside). *) + method! visit_abs env abs = + if ek.enter_abs then super#visit_abs env abs else abs + end + in + + let ctx = obj#visit_eval_ctx () ctx in + (* Check that we updated at least one loan *) + assert !r; + ctx + +(** Update a abstraction loan content. + + The loan is referred to by a borrow id. + + This is a helper function: it might break invariants. + *) +let update_aloan (ek : exploration_kind) (l : V.BorrowId.id) + (nlc : V.aloan_content) (ctx : C.eval_ctx) : C.eval_ctx = + (* We use a reference to check that we update exactly one loan: when updating + * inside values, we check we don't update more than one loan. Then, upon + * returning we check that we updated at least once. *) + let r = ref false in + let update () : V.aloan_content = + assert (not !r); + r := true; + nlc + in + + let obj = + object + inherit [_] C.map_eval_ctx as super + + method! visit_aloan_content env lc = + match lc with + | V.AMutLoan (bid, av) -> + if bid = l then update () else super#visit_AMutLoan env bid av + | V.ASharedLoan (bids, v, av) -> + if V.BorrowId.Set.mem l bids then update () + else super#visit_ASharedLoan env bids v av + | V.AEndedMutLoan { given_back = _; child = _; given_back_meta = _ } + | V.AEndedSharedLoan (_, _) + | V.AIgnoredMutLoan (_, _) + | V.AEndedIgnoredMutLoan + { given_back = _; child = _; given_back_meta = _ } + | V.AIgnoredSharedLoan _ -> + super#visit_aloan_content env lc + + (** Note that once inside the abstractions, we don't control diving + (there are no use cases requiring finer control). *) + method! visit_abs env abs = + if ek.enter_abs then super#visit_abs env abs else abs + end + in + + let ctx = obj#visit_eval_ctx () ctx in + (* Check that we updated at least one loan *) + assert !r; + ctx + +(** Lookup a borrow content from a borrow id. *) +let lookup_borrow_opt (ek : exploration_kind) (l : V.BorrowId.id) + (ctx : C.eval_ctx) : g_borrow_content option = + let obj = + object + inherit [_] C.iter_eval_ctx as super + + method! visit_borrow_content env bc = + match bc with + | V.MutBorrow (bid, mv) -> + (* Check the borrow id and control the dive *) + if bid = l then raise (FoundGBorrowContent (Concrete bc)) + else if ek.enter_mut_borrows then super#visit_MutBorrow env bid mv + else () + | V.SharedBorrow (_, bid) -> + (* Check the borrow id *) + if bid = l then raise (FoundGBorrowContent (Concrete bc)) else () + | V.InactivatedMutBorrow (_, bid) -> + (* Check the borrow id *) + if bid = l then raise (FoundGBorrowContent (Concrete bc)) else () + + method! visit_loan_content env lc = + match lc with + | V.MutLoan bid -> + (* Nothing special to do *) super#visit_MutLoan env bid + | V.SharedLoan (bids, sv) -> + (* Control the dive *) + if ek.enter_shared_loans then super#visit_SharedLoan env bids sv + else () + + method! visit_aborrow_content env bc = + match bc with + | V.AMutBorrow (mv, bid, av) -> + if bid = l then raise (FoundGBorrowContent (Abstract bc)) + else super#visit_AMutBorrow env mv bid av + | V.ASharedBorrow bid -> + if bid = l then raise (FoundGBorrowContent (Abstract bc)) + else super#visit_ASharedBorrow env bid + | V.AIgnoredMutBorrow (_, _) + | V.AEndedMutBorrow _ + | V.AEndedIgnoredMutBorrow + { given_back_loans_proj = _; child = _; given_back_meta = _ } + | V.AEndedSharedBorrow -> + super#visit_aborrow_content env bc + | V.AProjSharedBorrow asb -> + if borrow_in_asb l asb then + raise (FoundGBorrowContent (Abstract bc)) + else () + + method! visit_abs env abs = + if ek.enter_abs then super#visit_abs env abs else () + end + in + (* We use exceptions *) + try + obj#visit_eval_ctx () ctx; + None + with FoundGBorrowContent lc -> Some lc + +(** Lookup a borrow content from a borrow id. + + Raise an exception if no loan was found +*) +let lookup_borrow (ek : exploration_kind) (l : V.BorrowId.id) (ctx : C.eval_ctx) + : g_borrow_content = + match lookup_borrow_opt ek l ctx with + | None -> failwith "Unreachable" + | Some lc -> lc + +(** Update a borrow content. + + The borrow is referred to by a borrow id. + + This is a helper function: it might break invariants. + *) +let update_borrow (ek : exploration_kind) (l : V.BorrowId.id) + (nbc : V.borrow_content) (ctx : C.eval_ctx) : C.eval_ctx = + (* We use a reference to check that we update exactly one borrow: when updating + * inside values, we check we don't update more than one borrow. Then, upon + * returning we check that we updated at least once. *) + let r = ref false in + let update () : V.borrow_content = + assert (not !r); + r := true; + nbc + in + + let obj = + object + inherit [_] C.map_eval_ctx as super + + method! visit_borrow_content env bc = + match bc with + | V.MutBorrow (bid, mv) -> + (* Check the id and control dive *) + if bid = l then update () + else if ek.enter_mut_borrows then super#visit_MutBorrow env bid mv + else V.MutBorrow (bid, mv) + | V.SharedBorrow (mv, bid) -> + (* Check the id *) + if bid = l then update () else super#visit_SharedBorrow env mv bid + | V.InactivatedMutBorrow (mv, bid) -> + (* Check the id *) + if bid = l then update () + else super#visit_InactivatedMutBorrow env mv bid + + method! visit_loan_content env lc = + match lc with + | V.SharedLoan (bids, sv) -> + (* Control the dive *) + if ek.enter_shared_loans then super#visit_SharedLoan env bids sv + else V.SharedLoan (bids, sv) + | V.MutLoan bid -> + (* Nothing specific to do *) + super#visit_MutLoan env bid + + method! visit_abs env abs = + if ek.enter_abs then super#visit_abs env abs else abs + end + in + + let ctx = obj#visit_eval_ctx () ctx in + (* Check that we updated at least one borrow *) + assert !r; + ctx + +(** Update an abstraction borrow content. + + The borrow is referred to by a borrow id. + + This is a helper function: it might break invariants. + *) +let update_aborrow (ek : exploration_kind) (l : V.BorrowId.id) (nv : V.avalue) + (ctx : C.eval_ctx) : C.eval_ctx = + (* We use a reference to check that we update exactly one borrow: when updating + * inside values, we check we don't update more than one borrow. Then, upon + * returning we check that we updated at least once. *) + let r = ref false in + let update () : V.avalue = + assert (not !r); + r := true; + nv + in + + let obj = + object + inherit [_] C.map_eval_ctx as super + + method! visit_ABorrow env bc = + match bc with + | V.AMutBorrow (mv, bid, av) -> + if bid = l then update () + else V.ABorrow (super#visit_AMutBorrow env mv bid av) + | V.ASharedBorrow bid -> + if bid = l then update () + else V.ABorrow (super#visit_ASharedBorrow env bid) + | V.AIgnoredMutBorrow _ | V.AEndedMutBorrow _ | V.AEndedSharedBorrow + | V.AEndedIgnoredMutBorrow _ -> + super#visit_ABorrow env bc + | V.AProjSharedBorrow asb -> + if borrow_in_asb l asb then update () + else V.ABorrow (super#visit_AProjSharedBorrow env asb) + + method! visit_abs env abs = + if ek.enter_abs then super#visit_abs env abs else abs + end + in + + let ctx = obj#visit_eval_ctx () ctx in + (* Check that we updated at least one borrow *) + assert !r; + ctx + +(** Auxiliary function: see its usage in [end_borrow_get_borrow_in_value] *) +let update_outer_borrows (outer : V.AbstractionId.id option * borrow_ids option) + (x : borrow_ids) : V.AbstractionId.id option * borrow_ids option = + let abs, opt = outer in + (abs, update_if_none opt x) + +(** Return the first loan we find in a value *) +let get_first_loan_in_value (v : V.typed_value) : V.loan_content option = + let obj = + object + inherit [_] V.iter_typed_value + method! visit_loan_content _ lc = raise (FoundLoanContent lc) + end + in + (* We use exceptions *) + try + obj#visit_typed_value () v; + None + with FoundLoanContent lc -> Some lc + +(** Return the first borrow we find in a value *) +let get_first_borrow_in_value (v : V.typed_value) : V.borrow_content option = + let obj = + object + inherit [_] V.iter_typed_value + method! visit_borrow_content _ bc = raise (FoundBorrowContent bc) + end + in + (* We use exceptions *) + try + obj#visit_typed_value () v; + None + with FoundBorrowContent bc -> Some bc + +(** Return the first loan or borrow content we find in a value (starting with + the outer ones). + + [with_borrows]: + - if true: return the first loan or borrow we find + - if false: return the first loan we find, do not dive into borrowed values + *) +let get_first_outer_loan_or_borrow_in_value (with_borrows : bool) + (v : V.typed_value) : loan_or_borrow_content option = + let obj = + object + inherit [_] V.iter_typed_value + + method! visit_borrow_content _ bc = + if with_borrows then raise (FoundBorrowContent bc) else () + + method! visit_loan_content _ lc = raise (FoundLoanContent lc) + end + in + (* We use exceptions *) + try + obj#visit_typed_value () v; + None + with + | FoundLoanContent lc -> Some (LoanContent lc) + | FoundBorrowContent bc -> Some (BorrowContent bc) + +type gproj_borrows = + | AProjBorrows of V.AbstractionId.id * V.symbolic_value + | ProjBorrows of V.symbolic_value + +let proj_borrows_intersects_proj_loans + (proj_borrows : T.RegionId.Set.t * V.symbolic_value * T.rty) + (proj_loans : T.RegionId.Set.t * V.symbolic_value) : bool = + let b_regions, b_sv, b_ty = proj_borrows in + let l_regions, l_sv = proj_loans in + if same_symbolic_id b_sv l_sv then + projections_intersect l_sv.V.sv_ty l_regions b_ty b_regions + else false + +(** Result of looking up aproj_borrows which intersect a given aproj_loans in + the context. + + Note that because we we force the expansion of primitively copyable values + before giving them to abstractions, we only have the following possibilities: + - no aproj_borrows, in which case the symbolic value was either dropped + or is in the context + - exactly one aproj_borrows over a non-shared value + - potentially several aproj_borrows over shared values + + The result contains the ids of the abstractions in which the projectors were + found, as well as the projection types used in those abstractions. +*) +type looked_up_aproj_borrows = + | NonSharedProj of V.AbstractionId.id * T.rty + | SharedProjs of (V.AbstractionId.id * T.rty) list + +(** Lookup the aproj_borrows (including aproj_shared_borrows) over a + symbolic value which intersect a given set of regions. + + [lookup_shared]: if [true] also explore projectors over shared values, + otherwise ignore. + + This is a helper function. +*) +let lookup_intersecting_aproj_borrows_opt (lookup_shared : bool) + (regions : T.RegionId.Set.t) (sv : V.symbolic_value) (ctx : C.eval_ctx) : + looked_up_aproj_borrows option = + let found : looked_up_aproj_borrows option ref = ref None in + let set_non_shared ((id, ty) : V.AbstractionId.id * T.rty) : unit = + match !found with + | None -> found := Some (NonSharedProj (id, ty)) + | Some _ -> failwith "Unreachable" + in + let add_shared (x : V.AbstractionId.id * T.rty) : unit = + match !found with + | None -> found := Some (SharedProjs [ x ]) + | Some (SharedProjs pl) -> found := Some (SharedProjs (x :: pl)) + | Some (NonSharedProj _) -> failwith "Unreachable" + in + let check_add_proj_borrows (is_shared : bool) abs sv' proj_ty = + if + proj_borrows_intersects_proj_loans + (abs.V.regions, sv', proj_ty) + (regions, sv) + then + let x = (abs.abs_id, proj_ty) in + if is_shared then add_shared x else set_non_shared x + else () + in + let obj = + object + inherit [_] C.iter_eval_ctx as super + method! visit_abs _ abs = super#visit_abs (Some abs) abs + + method! visit_abstract_shared_borrows abs asb = + (* Sanity check *) + (match !found with + | Some (NonSharedProj _) -> failwith "Unreachable" + | _ -> ()); + (* Explore *) + if lookup_shared then + let abs = Option.get abs in + let check asb = + match asb with + | V.AsbBorrow _ -> () + | V.AsbProjReborrows (sv', proj_ty) -> + let is_shared = true in + check_add_proj_borrows is_shared abs sv' proj_ty + in + List.iter check asb + else () + + method! visit_aproj abs sproj = + (let abs = Option.get abs in + match sproj with + | AProjLoans _ | AEndedProjLoans _ | AEndedProjBorrows _ + | AIgnoredProjBorrows -> + () + | AProjBorrows (sv', proj_rty) -> + let is_shared = false in + check_add_proj_borrows is_shared abs sv' proj_rty); + super#visit_aproj abs sproj + end + in + (* Visit *) + obj#visit_eval_ctx None ctx; + (* Return *) + !found + +(** Lookup the aproj_borrows (not aproj_borrows_shared!) over a symbolic + value which intersects a given set of regions. + + Note that there should be **at most one** (one reason is that we force + the expansion of primitively copyable values before giving them to + abstractions). + + Returns the id of the owning abstraction, and the projection type used in + this abstraction. +*) +let lookup_intersecting_aproj_borrows_not_shared_opt + (regions : T.RegionId.Set.t) (sv : V.symbolic_value) (ctx : C.eval_ctx) : + (V.AbstractionId.id * T.rty) option = + let lookup_shared = false in + match lookup_intersecting_aproj_borrows_opt lookup_shared regions sv ctx with + | None -> None + | Some (NonSharedProj (abs_id, rty)) -> Some (abs_id, rty) + | _ -> failwith "Unexpected" + +(** Similar to {!lookup_intersecting_aproj_borrows_opt}, but updates the + values. + + This is a helper function: it might break invariants. + *) +let update_intersecting_aproj_borrows (can_update_shared : bool) + (update_shared : V.AbstractionId.id -> T.rty -> V.abstract_shared_borrows) + (update_non_shared : V.AbstractionId.id -> T.rty -> V.aproj) + (regions : T.RegionId.Set.t) (sv : V.symbolic_value) (ctx : C.eval_ctx) : + C.eval_ctx = + (* Small helpers for sanity checks *) + let shared = ref None in + let add_shared () = + match !shared with None -> shared := Some true | Some b -> assert b + in + let set_non_shared () = + match !shared with + | None -> shared := Some false + | Some _ -> failwith "Found unexpected intersecting proj_borrows" + in + let check_proj_borrows is_shared abs sv' proj_ty = + if + proj_borrows_intersects_proj_loans + (abs.V.regions, sv', proj_ty) + (regions, sv) + then ( + if is_shared then add_shared () else set_non_shared (); + true) + else false + in + (* The visitor *) + let obj = + object + inherit [_] C.map_eval_ctx as super + method! visit_abs _ abs = super#visit_abs (Some abs) abs + + method! visit_abstract_shared_borrows abs asb = + (* Sanity check *) + (match !shared with Some b -> assert b | _ -> ()); + (* Explore *) + if can_update_shared then + let abs = Option.get abs in + let update (asb : V.abstract_shared_borrow) : + V.abstract_shared_borrows = + match asb with + | V.AsbBorrow _ -> [ asb ] + | V.AsbProjReborrows (sv', proj_ty) -> + let is_shared = true in + if check_proj_borrows is_shared abs sv' proj_ty then + update_shared abs.abs_id proj_ty + else [ asb ] + in + List.concat (List.map update asb) + else asb + + method! visit_aproj abs sproj = + match sproj with + | AProjLoans _ | AEndedProjLoans _ | AEndedProjBorrows _ + | AIgnoredProjBorrows -> + super#visit_aproj abs sproj + | AProjBorrows (sv', proj_rty) -> + let abs = Option.get abs in + let is_shared = true in + if check_proj_borrows is_shared abs sv' proj_rty then + update_non_shared abs.abs_id proj_rty + else super#visit_aproj (Some abs) sproj + end + in + (* Apply *) + let ctx = obj#visit_eval_ctx None ctx in + (* Check that we updated the context at least once *) + assert (Option.is_some !shared); + (* Return *) + ctx + +(** Simply calls {!update_intersecting_aproj_borrows} to update a + proj_borrows over a non-shared value. + + We check that we update *at least* one proj_borrows. + + This is a helper function: it might break invariants. + *) +let update_intersecting_aproj_borrows_non_shared (regions : T.RegionId.Set.t) + (sv : V.symbolic_value) (nv : V.aproj) (ctx : C.eval_ctx) : C.eval_ctx = + (* Small helpers *) + let can_update_shared = false in + let update_shared _ _ = failwith "Unexpected" in + let updated = ref false in + let update_non_shared _ _ = + (* We can update more than one borrow! *) + updated := true; + nv + in + (* Update *) + let ctx = + update_intersecting_aproj_borrows can_update_shared update_shared + update_non_shared regions sv ctx + in + (* Check that we updated at least once *) + assert !updated; + (* Return *) + ctx + +(** Simply calls {!update_intersecting_aproj_borrows} to remove the + proj_borrows over shared values. + + This is a helper function: it might break invariants. + *) +let remove_intersecting_aproj_borrows_shared (regions : T.RegionId.Set.t) + (sv : V.symbolic_value) (ctx : C.eval_ctx) : C.eval_ctx = + (* Small helpers *) + let can_update_shared = true in + let update_shared _ _ = [] in + let update_non_shared _ _ = failwith "Unexpected" in + (* Update *) + update_intersecting_aproj_borrows can_update_shared update_shared + update_non_shared regions sv ctx + +(** Updates the proj_loans intersecting some projection. + + This is a helper function: it might break invariants. + + Note that we can update more than one projector of loans! Consider the + following example: + {[ + fn f<'a, 'b>(...) -> (&'a mut u32, &'b mut u32)); + fn g<'c>(&'c mut u32, &'c mut u32); + + let p = f(...); + g(move p); + + // Symbolic context after the call to g: + // abs'a {'a} { [s@0 <: (&'a mut u32, &'b mut u32)] } + // abs'b {'b} { [s@0 <: (&'a mut u32, &'b mut u32)] } + // + // abs'c {'c} { (s@0 <: (&'c mut u32, &'c mut u32)) } + ]} + + Note that for sanity, this function checks that we update *at least* one + projector of loans. + + [subst]: takes as parameters the abstraction in which we perform the + substitution and the list of given back values at the projector of + loans where we perform the substitution (see the fields in {!V.AProjLoans}). + Note that the symbolic value at this place is necessarily equal to [sv], + which is why we don't give it as parameters. + *) +let update_intersecting_aproj_loans (proj_regions : T.RegionId.Set.t) + (proj_ty : T.rty) (sv : V.symbolic_value) + (subst : V.abs -> (V.msymbolic_value * V.aproj) list -> V.aproj) + (ctx : C.eval_ctx) : C.eval_ctx = + (* Small helpers for sanity checks *) + let updated = ref false in + let update abs local_given_back : V.aproj = + (* Note that we can update more than once! *) + updated := true; + subst abs local_given_back + in + (* The visitor *) + let obj = + object + inherit [_] C.map_eval_ctx as super + method! visit_abs _ abs = super#visit_abs (Some abs) abs + + method! visit_aproj abs sproj = + match sproj with + | AProjBorrows _ | AEndedProjLoans _ | AEndedProjBorrows _ + | AIgnoredProjBorrows -> + super#visit_aproj abs sproj + | AProjLoans (sv', given_back) -> + let abs = Option.get abs in + if same_symbolic_id sv sv' then ( + assert (sv.sv_ty = sv'.sv_ty); + if + projections_intersect proj_ty proj_regions sv'.V.sv_ty + abs.regions + then update abs given_back + else super#visit_aproj (Some abs) sproj) + else super#visit_aproj (Some abs) sproj + end + in + (* Apply *) + let ctx = obj#visit_eval_ctx None ctx in + (* Check that we updated the context at least once *) + assert !updated; + (* Return *) + ctx + +(** Helper function: lookup an {!V.AProjLoans} by using an abstraction id and a + symbolic value. + + We return the information from the looked up projector of loans. See the + fields in {!V.AProjLoans} (we don't return the symbolic value, because it + is equal to [sv]). + + Sanity check: we check that there is exactly one projector which corresponds + to the couple (abstraction id, symbolic value). + *) +let lookup_aproj_loans (abs_id : V.AbstractionId.id) (sv : V.symbolic_value) + (ctx : C.eval_ctx) : (V.msymbolic_value * V.aproj) list = + (* Small helpers for sanity checks *) + let found = ref None in + let set_found x = + (* There is at most one projector which corresponds to the description *) + assert (Option.is_none !found); + found := Some x + in + (* The visitor *) + let obj = + object + inherit [_] C.iter_eval_ctx as super + + method! visit_abs _ abs = + if abs.abs_id = abs_id then super#visit_abs (Some abs) abs else () + + method! visit_aproj (abs : V.abs option) sproj = + (match sproj with + | AProjBorrows _ | AEndedProjLoans _ | AEndedProjBorrows _ + | AIgnoredProjBorrows -> + super#visit_aproj abs sproj + | AProjLoans (sv', given_back) -> + let abs = Option.get abs in + assert (abs.abs_id = abs_id); + if sv'.sv_id = sv.sv_id then ( + assert (sv' = sv); + set_found given_back) + else ()); + super#visit_aproj abs sproj + end + in + (* Apply *) + obj#visit_eval_ctx None ctx; + (* Return *) + Option.get !found + +(** Helper function: might break invariants. + + Update a projector over loans. The projector is identified by a symbolic + value and an abstraction id. + + Sanity check: we check that there is exactly one projector which corresponds + to the couple (abstraction id, symbolic value). + *) +let update_aproj_loans (abs_id : V.AbstractionId.id) (sv : V.symbolic_value) + (nproj : V.aproj) (ctx : C.eval_ctx) : C.eval_ctx = + (* Small helpers for sanity checks *) + let found = ref false in + let update () = + (* We update at most once *) + assert (not !found); + found := true; + nproj + in + (* The visitor *) + let obj = + object + inherit [_] C.map_eval_ctx as super + + method! visit_abs _ abs = + if abs.abs_id = abs_id then super#visit_abs (Some abs) abs else abs + + method! visit_aproj (abs : V.abs option) sproj = + match sproj with + | AProjBorrows _ | AEndedProjLoans _ | AEndedProjBorrows _ + | AIgnoredProjBorrows -> + super#visit_aproj abs sproj + | AProjLoans (sv', _) -> + let abs = Option.get abs in + assert (abs.abs_id = abs_id); + if sv'.sv_id = sv.sv_id then ( + assert (sv' = sv); + update ()) + else super#visit_aproj (Some abs) sproj + end + in + (* Apply *) + let ctx = obj#visit_eval_ctx None ctx in + (* Sanity check *) + assert !found; + (* Return *) + ctx + +(** Helper function: might break invariants. + + Update a projector over borrows. The projector is identified by a symbolic + value and an abstraction id. + + Sanity check: we check that there is exactly one projector which corresponds + to the couple (abstraction id, symbolic value). + + TODO: factorize with {!update_aproj_loans}? + *) +let update_aproj_borrows (abs_id : V.AbstractionId.id) (sv : V.symbolic_value) + (nproj : V.aproj) (ctx : C.eval_ctx) : C.eval_ctx = + (* Small helpers for sanity checks *) + let found = ref false in + let update () = + (* We update at most once *) + assert (not !found); + found := true; + nproj + in + (* The visitor *) + let obj = + object + inherit [_] C.map_eval_ctx as super + + method! visit_abs _ abs = + if abs.abs_id = abs_id then super#visit_abs (Some abs) abs else abs + + method! visit_aproj (abs : V.abs option) sproj = + match sproj with + | AProjLoans _ | AEndedProjLoans _ | AEndedProjBorrows _ + | AIgnoredProjBorrows -> + super#visit_aproj abs sproj + | AProjBorrows (sv', _proj_ty) -> + let abs = Option.get abs in + assert (abs.abs_id = abs_id); + if sv'.sv_id = sv.sv_id then ( + assert (sv' = sv); + update ()) + else super#visit_aproj (Some abs) sproj + end + in + (* Apply *) + let ctx = obj#visit_eval_ctx None ctx in + (* Sanity check *) + assert !found; + (* Return *) + ctx + +(** Helper function: might break invariants. + + Converts an {!V.AProjLoans} to an {!V.AEndedProjLoans}. The projector is identified + by a symbolic value and an abstraction id. + *) +let update_aproj_loans_to_ended (abs_id : V.AbstractionId.id) + (sv : V.symbolic_value) (ctx : C.eval_ctx) : C.eval_ctx = + (* Lookup the projector of loans *) + let given_back = lookup_aproj_loans abs_id sv ctx in + (* Create the new value for the projector *) + let nproj = V.AEndedProjLoans (sv, given_back) in + (* Insert it *) + let ctx = update_aproj_loans abs_id sv nproj ctx in + (* Return *) + ctx + +let no_aproj_over_symbolic_in_context (sv : V.symbolic_value) (ctx : C.eval_ctx) + : unit = + (* The visitor *) + let obj = + object + inherit [_] C.iter_eval_ctx as super + + method! visit_aproj env sproj = + (match sproj with + | AEndedProjLoans _ | AEndedProjBorrows _ | AIgnoredProjBorrows -> () + | AProjLoans (sv', _) | AProjBorrows (sv', _) -> + if sv'.sv_id = sv.sv_id then raise Found else ()); + super#visit_aproj env sproj + end + in + (* Apply *) + try obj#visit_eval_ctx () ctx + with Found -> failwith "update_aproj_loans_to_ended: failed" + +(** Helper function + + Return the loan (aloan, loan, proj_loans over a symbolic value) we find + in an abstraction, if there is. + + **Remark:** we don't take the *ignored* mut/shared loans into account. + *) +let get_first_non_ignored_aloan_in_abstraction (abs : V.abs) : + borrow_ids_or_symbolic_value option = + (* Explore to find a loan *) + let obj = + object + inherit [_] V.iter_abs as super + + method! visit_aloan_content env lc = + match lc with + | V.AMutLoan (bid, _) -> raise (FoundBorrowIds (Borrow bid)) + | V.ASharedLoan (bids, _, _) -> raise (FoundBorrowIds (Borrows bids)) + | V.AEndedMutLoan { given_back = _; child = _; given_back_meta = _ } + | V.AEndedSharedLoan (_, _) -> + super#visit_aloan_content env lc + | V.AIgnoredMutLoan (_, _) -> + (* Ignore *) + super#visit_aloan_content env lc + | V.AEndedIgnoredMutLoan + { given_back = _; child = _; given_back_meta = _ } + | V.AIgnoredSharedLoan _ -> + (* Ignore *) + super#visit_aloan_content env lc + + (** We may need to visit loan contents because of shared values *) + method! visit_loan_content _ lc = + match lc with + | V.MutLoan _ -> + (* The mut loan linked to the mutable borrow present in a shared + * value in an abstraction should be in an AProjBorrows *) + failwith "Unreachable" + | V.SharedLoan (bids, _) -> raise (FoundBorrowIds (Borrows bids)) + + method! visit_aproj env sproj = + (match sproj with + | V.AProjBorrows (_, _) + | V.AEndedProjLoans _ | V.AEndedProjBorrows _ | V.AIgnoredProjBorrows -> + () + | V.AProjLoans (sv, _) -> raise (ValuesUtils.FoundSymbolicValue sv)); + super#visit_aproj env sproj + end + in + try + (* Check if there are loans *) + obj#visit_abs () abs; + (* No loans *) + None + with + (* There are loans *) + | FoundBorrowIds bids -> Some (BorrowIds bids) + | ValuesUtils.FoundSymbolicValue sv -> + (* There are loan projections over symbolic values *) + Some (SymbolicValue sv) diff --git a/compiler/InterpreterExpansion.ml b/compiler/InterpreterExpansion.ml new file mode 100644 index 00000000..0ca34b43 --- /dev/null +++ b/compiler/InterpreterExpansion.ml @@ -0,0 +1,733 @@ +(* This module provides the functions which handle expansion of symbolic values. + * For now, this file doesn't handle expansion of ⊥ values because they need + * some path utilities for replacement. We might change that in the future (by + * using indices to identify the values for instance). *) + +module T = Types +module V = Values +module E = Expressions +module C = Contexts +module Subst = Substitute +module L = Logging +open TypesUtils +module Inv = Invariants +module S = SynthesizeSymbolic +module SA = SymbolicAst +open Cps +open ValuesUtils +open InterpreterUtils +open InterpreterProjectors +open InterpreterBorrows + +(** The local logger *) +let log = L.expansion_log + +(** Projector kind *) +type proj_kind = LoanProj | BorrowProj + +(** Auxiliary function. + Apply a symbolic expansion to avalues in a context, targetting a specific + kind of projectors. + + [proj_kind] controls whether we apply the expansion to projectors + on loans or projectors on borrows. + + When dealing with reference expansion, it is necessary to first apply the + expansion on loan projectors, then on borrow projectors. The reason is + that reducing the borrow projectors might require to perform some reborrows, + in which case we need to lookup the corresponding loans in the context. + + [allow_reborrows] controls whether we allow reborrows or not. It is useful + only if we target borrow projectors. + + Also, if this function is called on an expansion for *shared references*, + the proj borrows should already have been expanded. + + TODO: the way this function is used is a bit complex, especially because of + the above condition. Maybe we should have: + 1. a generic function to expand the loan projectors + 2. a function to expand the borrow projectors for non-borrows + 3. specialized functions for mut borrows and shared borrows + Note that 2. and 3. may have a little bit of duplicated code, but hopefully + it would make things clearer. +*) +let apply_symbolic_expansion_to_target_avalues (config : C.config) + (allow_reborrows : bool) (proj_kind : proj_kind) + (original_sv : V.symbolic_value) (expansion : V.symbolic_expansion) + (ctx : C.eval_ctx) : C.eval_ctx = + (* Symbolic values contained in the expansion might contain already ended regions *) + let check_symbolic_no_ended = false in + (* Prepare reborrows registration *) + let fresh_reborrow, apply_registered_reborrows = + prepare_reborrows config allow_reborrows + in + (* Visitor to apply the expansion *) + let obj = + object (self) + inherit [_] C.map_eval_ctx as super + + (** When visiting an abstraction, we remember the regions it owns to be + able to properly reduce projectors when expanding symbolic values *) + method! visit_abs current_abs abs = + assert (Option.is_none current_abs); + let current_abs = Some abs in + super#visit_abs current_abs abs + + (** We carefully updated {!visit_ASymbolic} so that {!visit_aproj} is called + only on child projections (i.e., projections which appear in {!AEndedProjLoans}). + The role of visit_aproj is then to check we don't have to expand symbolic + values in child projections, because it should never happen + *) + method! visit_aproj current_abs aproj = + (match aproj with + | AProjLoans (sv, _) | AProjBorrows (sv, _) -> + assert (not (same_symbolic_id sv original_sv)) + | AEndedProjLoans _ | AEndedProjBorrows _ | AIgnoredProjBorrows -> ()); + super#visit_aproj current_abs aproj + + method! visit_ASymbolic current_abs aproj = + let current_abs = Option.get current_abs in + let proj_regions = current_abs.regions in + let ancestors_regions = current_abs.ancestors_regions in + (* Explore in depth first - we won't update anything: we simply + * want to check we don't have to expand inner symbolic value *) + match (aproj, proj_kind) with + | V.AEndedProjBorrows _, _ -> V.ASymbolic aproj + | V.AEndedProjLoans _, _ -> + (* Explore the given back values to make sure we don't have to expand + * anything in there *) + V.ASymbolic (self#visit_aproj (Some current_abs) aproj) + | V.AProjLoans (sv, given_back), LoanProj -> + (* Check if this is the symbolic value we are looking for *) + if same_symbolic_id sv original_sv then ( + (* There mustn't be any given back values *) + assert (given_back = []); + (* Apply the projector *) + let projected_value = + apply_proj_loans_on_symbolic_expansion proj_regions expansion + original_sv.V.sv_ty + in + (* Replace *) + projected_value.V.value) + else + (* Not the searched symbolic value: nothing to do *) + super#visit_ASymbolic (Some current_abs) aproj + | V.AProjBorrows (sv, proj_ty), BorrowProj -> + (* Check if this is the symbolic value we are looking for *) + if same_symbolic_id sv original_sv then + (* Convert the symbolic expansion to a value on which we can + * apply a projector (if the expansion is a reference expansion, + * convert it to a borrow) *) + (* WARNING: we mustn't get there if the expansion is for a shared + * reference. *) + let expansion = + symbolic_expansion_non_shared_borrow_to_value original_sv + expansion + in + (* Apply the projector *) + let projected_value = + apply_proj_borrows check_symbolic_no_ended ctx fresh_reborrow + proj_regions ancestors_regions expansion proj_ty + in + (* Replace *) + projected_value.V.value + else + (* Not the searched symbolic value: nothing to do *) + super#visit_ASymbolic (Some current_abs) aproj + | V.AProjLoans _, BorrowProj + | V.AProjBorrows (_, _), LoanProj + | V.AIgnoredProjBorrows, _ -> + (* Nothing to do *) + V.ASymbolic aproj + end + in + (* Apply the expansion *) + let ctx = obj#visit_eval_ctx None ctx in + (* Apply the reborrows *) + apply_registered_reborrows ctx + +(** Auxiliary function. + Apply a symbolic expansion to avalues in a context. +*) +let apply_symbolic_expansion_to_avalues (config : C.config) + (allow_reborrows : bool) (original_sv : V.symbolic_value) + (expansion : V.symbolic_expansion) (ctx : C.eval_ctx) : C.eval_ctx = + let apply_expansion proj_kind ctx = + apply_symbolic_expansion_to_target_avalues config allow_reborrows proj_kind + original_sv expansion ctx + in + (* First target the loan projectors, then the borrow projectors *) + let ctx = apply_expansion LoanProj ctx in + let ctx = apply_expansion BorrowProj ctx in + ctx + +(** Auxiliary function. + + Simply replace the symbolic values (*not avalues*) in the context with + a given value. Will break invariants if not used properly. +*) +let replace_symbolic_values (at_most_once : bool) + (original_sv : V.symbolic_value) (nv : V.value) (ctx : C.eval_ctx) : + C.eval_ctx = + (* Count *) + let replaced = ref false in + let replace () = + if at_most_once then assert (not !replaced); + replaced := true; + nv + in + (* Visitor to apply the substitution *) + let obj = + object + inherit [_] C.map_eval_ctx as super + + method! visit_Symbolic env spc = + if same_symbolic_id spc original_sv then replace () + else super#visit_Symbolic env spc + end + in + (* Apply the substitution *) + let ctx = obj#visit_eval_ctx None ctx in + (* Return *) + ctx + +(** Apply a symbolic expansion to a context, by replacing the original + symbolic value with its expanded value. Is valid only if the expansion + is not a borrow (i.e., an adt...). + + This function does update the synthesis. +*) +let apply_symbolic_expansion_non_borrow (config : C.config) + (original_sv : V.symbolic_value) (expansion : V.symbolic_expansion) + (ctx : C.eval_ctx) : C.eval_ctx = + (* Apply the expansion to non-abstraction values *) + let nv = symbolic_expansion_non_borrow_to_value original_sv expansion in + let at_most_once = false in + let ctx = replace_symbolic_values at_most_once original_sv nv.V.value ctx in + (* Apply the expansion to abstraction values *) + let allow_reborrows = false in + apply_symbolic_expansion_to_avalues config allow_reborrows original_sv + expansion ctx + +(** Compute the expansion of an adt value. + + The function might return a list of values if the symbolic value to expand + is an enumeration. + + [expand_enumerations] controls the expansion of enumerations: if false, it + doesn't allow the expansion of enumerations *containing several variants*. + *) +let compute_expanded_symbolic_adt_value (expand_enumerations : bool) + (kind : V.sv_kind) (def_id : T.TypeDeclId.id) + (regions : T.RegionId.id T.region list) (types : T.rty list) + (ctx : C.eval_ctx) : V.symbolic_expansion list = + (* Lookup the definition and check if it is an enumeration with several + * variants *) + let def = C.ctx_lookup_type_decl ctx def_id in + assert (List.length regions = List.length def.T.region_params); + (* Retrieve, for every variant, the list of its instantiated field types *) + let variants_fields_types = + Subst.type_decl_get_instantiated_variants_fields_rtypes def regions types + in + (* Check if there is strictly more than one variant *) + if List.length variants_fields_types > 1 && not expand_enumerations then + raise (Failure "Not allowed to expand enumerations with several variants"); + (* Initialize the expanded value for a given variant *) + let initialize + ((variant_id, field_types) : T.VariantId.id option * T.rty list) : + V.symbolic_expansion = + let field_values = + List.map (fun (ty : T.rty) -> mk_fresh_symbolic_value kind ty) field_types + in + let see = V.SeAdt (variant_id, field_values) in + see + in + (* Initialize all the expanded values of all the variants *) + List.map initialize variants_fields_types + +(** Compute the expansion of an Option value. + *) +let compute_expanded_symbolic_option_value (expand_enumerations : bool) + (kind : V.sv_kind) (ty : T.rty) : V.symbolic_expansion list = + assert expand_enumerations; + let some_se = + V.SeAdt (Some T.option_some_id, [ mk_fresh_symbolic_value kind ty ]) + in + let none_se = V.SeAdt (Some T.option_none_id, []) in + [ none_se; some_se ] + +let compute_expanded_symbolic_tuple_value (kind : V.sv_kind) + (field_types : T.rty list) : V.symbolic_expansion = + (* Generate the field values *) + let field_values = + List.map (fun sv_ty -> mk_fresh_symbolic_value kind sv_ty) field_types + in + let variant_id = None in + let see = V.SeAdt (variant_id, field_values) in + see + +let compute_expanded_symbolic_box_value (kind : V.sv_kind) (boxed_ty : T.rty) : + V.symbolic_expansion = + (* Introduce a fresh symbolic value *) + let boxed_value = mk_fresh_symbolic_value kind boxed_ty in + let see = V.SeAdt (None, [ boxed_value ]) in + see + +let expand_symbolic_value_shared_borrow (config : C.config) + (original_sv : V.symbolic_value) (original_sv_place : SA.mplace option) + (ref_ty : T.rty) : cm_fun = + fun cf ctx -> + (* First, replace the projectors on borrows. + * The important point is that the symbolic value to expand may appear + * several times, if it has been copied. In this case, we need to introduce + * one fresh borrow id per instance. + *) + let borrows = ref V.BorrowId.Set.empty in + let fresh_borrow () = + let bid' = C.fresh_borrow_id () in + borrows := V.BorrowId.Set.add bid' !borrows; + bid' + in + (* Small utility used on shared borrows in abstractions (regular borrow + * projector and asb). + * Returns [Some] if the symbolic value has been expanded to an asb list, + * [None] otherwise *) + let reborrow_ashared proj_regions (sv : V.symbolic_value) (proj_ty : T.rty) : + V.abstract_shared_borrows option = + if same_symbolic_id sv original_sv then + match proj_ty with + | T.Ref (r, ref_ty, T.Shared) -> + (* Projector over the shared value *) + let shared_asb = V.AsbProjReborrows (sv, ref_ty) in + (* Check if the region is in the set of projected regions *) + if region_in_set r proj_regions then + (* In the set: we need to reborrow *) + let bid = fresh_borrow () in + Some [ V.AsbBorrow bid; shared_asb ] + else (* Not in the set: ignore *) + Some [ shared_asb ] + | _ -> raise (Failure "Unexpected") + else None + in + (* The fresh symbolic value for the shared value *) + let shared_sv = mk_fresh_symbolic_value original_sv.sv_kind ref_ty in + (* Visitor to replace the projectors on borrows *) + let obj = + object (self) + inherit [_] C.map_eval_ctx as super + + method! visit_Symbolic env sv = + if same_symbolic_id sv original_sv then + let bid = fresh_borrow () in + V.Borrow + (V.SharedBorrow (mk_typed_value_from_symbolic_value shared_sv, bid)) + else super#visit_Symbolic env sv + + method! visit_Abs proj_regions abs = + assert (Option.is_none proj_regions); + let proj_regions = Some abs.V.regions in + super#visit_Abs proj_regions abs + + method! visit_AProjSharedBorrow proj_regions asb = + let expand_asb (asb : V.abstract_shared_borrow) : + V.abstract_shared_borrows = + match asb with + | V.AsbBorrow _ -> [ asb ] + | V.AsbProjReborrows (sv, proj_ty) -> ( + match reborrow_ashared (Option.get proj_regions) sv proj_ty with + | None -> [ asb ] + | Some asb -> asb) + in + let asb = List.concat (List.map expand_asb asb) in + V.AProjSharedBorrow asb + + (** We carefully updated {!visit_ASymbolic} so that {!visit_aproj} is called + only on child projections (i.e., projections which appear in {!AEndedProjLoans}). + The role of visit_aproj is then to check we don't have to expand symbolic + values in child projections, because it should never happen + *) + method! visit_aproj proj_regions aproj = + (match aproj with + | AProjLoans (sv, _) | AProjBorrows (sv, _) -> + assert (not (same_symbolic_id sv original_sv)) + | AEndedProjLoans _ | AEndedProjBorrows _ | AIgnoredProjBorrows -> ()); + super#visit_aproj proj_regions aproj + + method! visit_ASymbolic proj_regions aproj = + match aproj with + | AEndedProjBorrows _ | AIgnoredProjBorrows -> + (* We ignore borrows *) V.ASymbolic aproj + | AProjLoans _ -> + (* Loans are handled later *) + V.ASymbolic aproj + | AProjBorrows (sv, proj_ty) -> ( + (* Check if we need to reborrow *) + match reborrow_ashared (Option.get proj_regions) sv proj_ty with + | None -> super#visit_ASymbolic proj_regions aproj + | Some asb -> V.ABorrow (V.AProjSharedBorrow asb)) + | AEndedProjLoans _ -> + (* Sanity check: make sure there is nothing to expand inside the + * children projections *) + V.ASymbolic (self#visit_aproj proj_regions aproj) + end + in + (* Call the visitor *) + let ctx = obj#visit_eval_ctx None ctx in + (* Finally, replace the projectors on loans *) + let bids = !borrows in + assert (not (V.BorrowId.Set.is_empty bids)); + let see = V.SeSharedRef (bids, shared_sv) in + let allow_reborrows = true in + let ctx = + apply_symbolic_expansion_to_avalues config allow_reborrows original_sv see + ctx + in + (* Call the continuation *) + let expr = cf ctx in + (* Update the synthesized program *) + S.synthesize_symbolic_expansion_no_branching original_sv original_sv_place see + expr + +(** TODO: simplify and merge with the other expansion function *) +let expand_symbolic_value_borrow (config : C.config) + (original_sv : V.symbolic_value) (original_sv_place : SA.mplace option) + (region : T.RegionId.id T.region) (ref_ty : T.rty) (rkind : T.ref_kind) : + cm_fun = + fun cf ctx -> + (* Check that we are allowed to expand the reference *) + assert (not (region_in_set region ctx.ended_regions)); + (* Match on the reference kind *) + match rkind with + | T.Mut -> + (* Simple case: simply create a fresh symbolic value and a fresh + * borrow id *) + let sv = mk_fresh_symbolic_value original_sv.sv_kind ref_ty in + let bid = C.fresh_borrow_id () in + let see = V.SeMutRef (bid, sv) in + (* Expand the symbolic values - we simply perform a substitution (and + * check that we perform exactly one substitution) *) + let nv = symbolic_expansion_non_shared_borrow_to_value original_sv see in + let at_most_once = true in + let ctx = + replace_symbolic_values at_most_once original_sv nv.V.value ctx + in + (* Expand the symbolic avalues *) + let allow_reborrows = true in + let ctx = + apply_symbolic_expansion_to_avalues config allow_reborrows original_sv + see ctx + in + (* Apply the continuation *) + let expr = cf ctx in + (* Update the synthesized program *) + S.synthesize_symbolic_expansion_no_branching original_sv original_sv_place + see expr + | T.Shared -> + expand_symbolic_value_shared_borrow config original_sv original_sv_place + ref_ty cf ctx + +(** A small helper. + + Apply a branching symbolic expansion to a context and execute all the + branches. Note that the expansion is optional for every branch (this is + used for integer expansion: see [expand_symbolic_int]). + + [see_cf_l]: list of pairs (optional symbolic expansion, continuation) +*) +let apply_branching_symbolic_expansions_non_borrow (config : C.config) + (sv : V.symbolic_value) (sv_place : SA.mplace option) + (see_cf_l : (V.symbolic_expansion option * m_fun) list) : m_fun = + fun ctx -> + assert (see_cf_l <> []); + (* Apply the symbolic expansion in in the context and call the continuation *) + let resl = + List.map + (fun (see_opt, cf) -> + (* Expansion *) + let ctx = + match see_opt with + | None -> ctx + | Some see -> apply_symbolic_expansion_non_borrow config sv see ctx + in + (* Continuation *) + cf ctx) + see_cf_l + in + (* Collect the result: either we computed no subterm, or we computed all + * of them *) + let subterms = + match resl with + | Some _ :: _ -> Some (List.map Option.get resl) + | None :: _ -> + List.iter (fun res -> assert (res = None)) resl; + None + | _ -> raise (Failure "Unreachable") + in + (* Synthesize and return *) + let seel = List.map fst see_cf_l in + S.synthesize_symbolic_expansion sv sv_place seel subterms + +(** Expand a symbolic boolean *) +let expand_symbolic_bool (config : C.config) (sp : V.symbolic_value) + (sp_place : SA.mplace option) (cf_true : m_fun) (cf_false : m_fun) : m_fun = + fun ctx -> + (* Compute the expanded value *) + let original_sv = sp in + let original_sv_place = sp_place in + let rty = original_sv.V.sv_ty in + assert (rty = T.Bool); + (* Expand the symbolic value to true or false and continue execution *) + let see_true = V.SeConcrete (V.Bool true) in + let see_false = V.SeConcrete (V.Bool false) in + let seel = [ (Some see_true, cf_true); (Some see_false, cf_false) ] in + (* Apply the symbolic expansion (this also outputs the updated symbolic AST) *) + apply_branching_symbolic_expansions_non_borrow config original_sv + original_sv_place seel ctx + +(** Expand a symbolic value. + + [allow_branching]: if [true] we can branch (by expanding enumerations with + stricly more than one variant), otherwise we can't. + + TODO: rename [sp] to [sv] + *) +let expand_symbolic_value (config : C.config) (allow_branching : bool) + (sp : V.symbolic_value) (sp_place : SA.mplace option) : cm_fun = + fun cf ctx -> + (* Debug *) + log#ldebug (lazy ("expand_symbolic_value:" ^ symbolic_value_to_string ctx sp)); + (* Remember the initial context for printing purposes *) + let ctx0 = ctx in + (* Compute the expanded value - note that when doing so, we may introduce + * fresh symbolic values in the context (which thus gets updated) *) + let original_sv = sp in + let original_sv_place = sp_place in + let rty = original_sv.V.sv_ty in + let cc : cm_fun = + fun cf ctx -> + match rty with + (* TODO: I think it is possible to factorize a lot the below match *) + (* "Regular" ADTs *) + | T.Adt (T.AdtId def_id, regions, types) -> + (* Compute the expanded value *) + let seel = + compute_expanded_symbolic_adt_value allow_branching sp.sv_kind def_id + regions types ctx + in + (* Check for branching *) + assert (List.length seel <= 1 || allow_branching); + (* Apply *) + let seel = List.map (fun see -> (Some see, cf)) seel in + apply_branching_symbolic_expansions_non_borrow config original_sv + original_sv_place seel ctx + (* Options *) + | T.Adt (T.Assumed Option, regions, types) -> + (* Sanity check *) + assert (regions = []); + let ty = Collections.List.to_cons_nil types in + (* Compute the expanded value *) + let seel = + compute_expanded_symbolic_option_value allow_branching sp.sv_kind ty + in + + (* Check for branching *) + assert (List.length seel <= 1 || allow_branching); + (* Apply *) + let seel = List.map (fun see -> (Some see, cf)) seel in + apply_branching_symbolic_expansions_non_borrow config original_sv + original_sv_place seel ctx + (* Tuples *) + | T.Adt (T.Tuple, [], tys) -> + (* Generate the field values *) + let see = compute_expanded_symbolic_tuple_value sp.sv_kind tys in + (* Apply in the context *) + let ctx = + apply_symbolic_expansion_non_borrow config original_sv see ctx + in + (* Call the continuation *) + let expr = cf ctx in + (* Update the synthesized program *) + S.synthesize_symbolic_expansion_no_branching original_sv + original_sv_place see expr + (* Boxes *) + | T.Adt (T.Assumed T.Box, [], [ boxed_ty ]) -> + let see = compute_expanded_symbolic_box_value sp.sv_kind boxed_ty in + (* Apply in the context *) + let ctx = + apply_symbolic_expansion_non_borrow config original_sv see ctx + in + (* Call the continuation *) + let expr = cf ctx in + (* Update the synthesized program *) + S.synthesize_symbolic_expansion_no_branching original_sv + original_sv_place see expr + (* Borrows *) + | T.Ref (region, ref_ty, rkind) -> + expand_symbolic_value_borrow config original_sv original_sv_place region + ref_ty rkind cf ctx + (* Booleans *) + | T.Bool -> + assert allow_branching; + expand_symbolic_bool config sp sp_place cf cf ctx + | _ -> + raise + (Failure ("expand_symbolic_value: unexpected type: " ^ T.show_rty rty)) + in + (* Debug *) + let cc = + comp_unit cc (fun ctx -> + log#ldebug + (lazy + ("expand_symbolic_value: " + ^ symbolic_value_to_string ctx0 sp + ^ "\n\n- original context:\n" ^ eval_ctx_to_string ctx0 + ^ "\n\n- new context:\n" ^ eval_ctx_to_string ctx ^ "\n")); + (* Sanity check: the symbolic value has disappeared *) + assert (not (symbolic_value_id_in_ctx original_sv.V.sv_id ctx))) + in + (* Continue *) + cc cf ctx + +(** Symbolic integers are expanded upon evaluating a [switch], when the integer + is not an enumeration discriminant. + Note that a discriminant is never symbolic: we evaluate discriminant values + upon evaluating [eval_discriminant], which always generates a concrete value + (because if we call it on a symbolic enumeration, we expand the enumeration + *then* evaluate the discriminant). This is how we can spot "regular" switches + over integers. + + + When expanding a boolean upon evaluating an [if ... then ... else ...], + or an enumeration just before matching over it, we can simply expand the + boolean/enumeration (generating a list of contexts from which to execute) + then retry evaluating the [if ... then ... else ...] or the [match]: as + the scrutinee will then have a concrete value, the interpreter will switch + to the proper branch. + + However, when expanding a "regular" integer for a switch, there is always an + *otherwise* branch that we can take, for which the integer must remain symbolic + (because in this branch the scrutinee can take a range of values). We thus + can't simply expand then retry to evaluate the [switch], because then we + would loop... + + For this reason, we take the list of branches to execute as parameters, and + directly jump to those branches after the expansion, without reevaluating the + switch. The continuation is thus for the execution *after* the switch. +*) +let expand_symbolic_int (config : C.config) (sv : V.symbolic_value) + (sv_place : SA.mplace option) (int_type : T.integer_type) + (tgts : (V.scalar_value * m_fun) list) (otherwise : m_fun) : m_fun = + (* Sanity check *) + assert (sv.V.sv_ty = T.Integer int_type); + (* For all the branches of the switch, we expand the symbolic value + * to the value given by the branch and execute the branch statement. + * For the otherwise branch, we leave the symbolic value as it is + * (because this branch doesn't precisely define which should be the + * value of the scrutinee...) and simply execute the otherwise statement. + * + * First, generate the list of pairs: + * (optional expansion, statement to execute) + *) + let tgts = + List.map (fun (v, cf) -> (Some (V.SeConcrete (V.Scalar v)), cf)) tgts + in + let tgts = List.append tgts [ (None, otherwise) ] in + (* Then expand and evaluate - this generates the proper symbolic AST *) + apply_branching_symbolic_expansions_non_borrow config sv sv_place tgts + +(** See [expand_symbolic_value] *) +let expand_symbolic_value_no_branching (config : C.config) + (sv : V.symbolic_value) (sv_place : SA.mplace option) : cm_fun = + let allow_branching = false in + expand_symbolic_value config allow_branching sv sv_place + +(** Expand all the symbolic values which contain borrows. + Allows us to restrict ourselves to a simpler model for the projectors over + symbolic values. + + Fails if doing this requires to do a branching (because we need to expand + an enumeration with strictly more than one variant, a slice, etc.) or if + we need to expand a recursive type (because this leads to looping). + *) +let greedy_expand_symbolics_with_borrows (config : C.config) : cm_fun = + fun cf ctx -> + (* The visitor object, to look for symbolic values in the concrete environment *) + let obj = + object + inherit [_] C.iter_eval_ctx + + method! visit_Symbolic _ sv = + if ty_has_borrows ctx.type_context.type_infos sv.V.sv_ty then + raise (FoundSymbolicValue sv) + else () + + (** Don't enter abstractions *) + method! visit_abs _ _ = () + end + in + + let rec expand : cm_fun = + fun cf ctx -> + try + obj#visit_eval_ctx () ctx; + (* Nothing to expand: continue *) + cf ctx + with FoundSymbolicValue sv -> + (* Expand and recheck the environment *) + log#ldebug + (lazy + ("greedy_expand_symbolics_with_borrows: about to expand: " + ^ symbolic_value_to_string ctx sv)); + let cc : cm_fun = + match sv.V.sv_ty with + | T.Adt (AdtId def_id, _, _) -> + (* {!expand_symbolic_value_no_branching} checks if there are branchings, + * but we prefer to also check it here - this leads to cleaner messages + * and debugging *) + let def = C.ctx_lookup_type_decl ctx def_id in + (match def.kind with + | T.Struct _ | T.Enum ([] | [ _ ]) -> () + | T.Enum (_ :: _) -> + raise + (Failure + ("Attempted to greedily expand a symbolic enumeration \ + with > 1 variants (option \ + [greedy_expand_symbolics_with_borrows] of [config]): " + ^ Print.name_to_string def.name)) + | T.Opaque -> + raise (Failure "Attempted to greedily expand an opaque type")); + (* Also, we need to check if the definition is recursive *) + if C.ctx_type_decl_is_rec ctx def_id then + raise + (Failure + ("Attempted to greedily expand a recursive definition \ + (option [greedy_expand_symbolics_with_borrows] of \ + [config]): " + ^ Print.name_to_string def.name)) + else expand_symbolic_value_no_branching config sv None + | T.Adt ((Tuple | Assumed Box), _, _) | T.Ref (_, _, _) -> + (* Ok *) + expand_symbolic_value_no_branching config sv None + | T.Adt (Assumed (Vec | Option), _, _) -> + (* We can't expand those *) + raise (Failure "Attempted to greedily expand a Vec or an Option ") + | T.Array _ -> raise Errors.Unimplemented + | T.Slice _ -> raise (Failure "Can't expand symbolic slices") + | T.TypeVar _ | Bool | Char | Never | Integer _ | Str -> + raise (Failure "Unreachable") + in + (* Compose and continue *) + comp cc expand cf ctx + in + (* Apply *) + expand cf ctx + +(** If this mode is activated through the [config], greedily expand the symbolic + values which need to be expanded. See [config] for more information. + *) +let greedy_expand_symbolic_values (config : C.config) : cm_fun = + fun cf ctx -> + if config.greedy_expand_symbolics_with_borrows then ( + log#ldebug (lazy "greedy_expand_symbolic_values"); + greedy_expand_symbolics_with_borrows config cf ctx) + else cf ctx diff --git a/compiler/InterpreterExpressions.ml b/compiler/InterpreterExpressions.ml new file mode 100644 index 00000000..62d9b80b --- /dev/null +++ b/compiler/InterpreterExpressions.ml @@ -0,0 +1,720 @@ +module T = Types +module V = Values +module LA = LlbcAst +open Scalars +module E = Expressions +open Errors +module C = Contexts +module Subst = Substitute +module L = Logging +module PV = Print.Values +open TypesUtils +open ValuesUtils +module Inv = Invariants +module S = SynthesizeSymbolic +open Cps +open InterpreterUtils +open InterpreterExpansion +open InterpreterPaths + +(** The local logger *) +let log = L.expressions_log + +(** As long as there are symbolic values at a given place (potentially in subvalues) + which contain borrows and are primitively copyable, expand them. + + We use this function before copying values. + + Note that the place should have been prepared so that there are no remaining + loans. +*) +let expand_primitively_copyable_at_place (config : C.config) + (access : access_kind) (p : E.place) : cm_fun = + fun cf ctx -> + (* Small helper *) + let rec expand : cm_fun = + fun cf ctx -> + let v = read_place_unwrap config access p ctx in + match + find_first_primitively_copyable_sv_with_borrows + ctx.type_context.type_infos v + with + | None -> cf ctx + | Some sv -> + let cc = + expand_symbolic_value_no_branching config sv + (Some (S.mk_mplace p ctx)) + in + comp cc expand cf ctx + in + (* Apply *) + expand cf ctx + +(** Read a place (CPS-style function). + + We also check that the value *doesn't contain bottoms or inactivated + borrows. + *) +let read_place (config : C.config) (access : access_kind) (p : E.place) + (cf : V.typed_value -> m_fun) : m_fun = + fun ctx -> + let v = read_place_unwrap config access p ctx in + (* Check that there are no bottoms in the value *) + assert (not (bottom_in_value ctx.ended_regions v)); + (* Check that there are no inactivated borrows in the value *) + assert (not (inactivated_in_value v)); + (* Call the continuation *) + cf v ctx + +(** Small utility. + + Prepare the access to a place in a right-value (typically an operand) by + reorganizing the environment. + + We reorganize the environment so that: + - we can access the place (we prepare *along* the path) + - the value at the place itself doesn't contain loans (the [access_kind] + controls whether we only end mutable loans, or also shared loans). + + We also check, after the reorganization, that the value at the place + *doesn't contain any bottom nor inactivated borrows*. + + [expand_prim_copy]: if true, expand the symbolic values which are primitively + copyable and contain borrows. + *) +let access_rplace_reorganize_and_read (config : C.config) + (expand_prim_copy : bool) (access : access_kind) (p : E.place) + (cf : V.typed_value -> m_fun) : m_fun = + fun ctx -> + (* Make sure we can evaluate the path *) + let cc = update_ctx_along_read_place config access p in + (* End the proper loans at the place itself *) + let cc = comp cc (end_loans_at_place config access p) in + (* Expand the copyable values which contain borrows (which are necessarily shared + * borrows) *) + let cc = + if expand_prim_copy then + comp cc (expand_primitively_copyable_at_place config access p) + else cc + in + (* Read the place - note that this checks that the value doesn't contain bottoms *) + let read_place = read_place config access p in + (* Compose *) + comp cc read_place cf ctx + +let access_rplace_reorganize (config : C.config) (expand_prim_copy : bool) + (access : access_kind) (p : E.place) : cm_fun = + fun cf ctx -> + access_rplace_reorganize_and_read config expand_prim_copy access p + (fun _v -> cf) + ctx + +(** Convert an operand constant operand value to a typed value *) +let constant_to_typed_value (ty : T.ety) (cv : V.constant_value) : V.typed_value + = + (* Check the type while converting - we actually need some information + * contained in the type *) + log#ldebug + (lazy + ("constant_to_typed_value:" ^ "\n- cv: " ^ PV.constant_value_to_string cv)); + match (ty, cv) with + (* Scalar, boolean... *) + | T.Bool, Bool v -> { V.value = V.Concrete (Bool v); ty } + | T.Char, Char v -> { V.value = V.Concrete (Char v); ty } + | T.Str, String v -> { V.value = V.Concrete (String v); ty } + | T.Integer int_ty, V.Scalar v -> + (* Check the type and the ranges *) + assert (int_ty = v.int_ty); + assert (check_scalar_value_in_range v); + { V.value = V.Concrete (V.Scalar v); ty } + (* Remaining cases (invalid) *) + | _, _ -> failwith "Improperly typed constant value" + +(** Reorganize the environment in preparation for the evaluation of an operand. + + Evaluating an operand requires reorganizing the environment to get access + to a given place (by ending borrows, expanding symbolic values...) then + applying the operand operation (move, copy, etc.). + + Sometimes, we want to decouple the two operations. + Consider the following example: + {[ + context = { + x -> shared_borrow l0 + y -> shared_loan {l0} v + } + + dest <- f(move x, move y); + ... + ]} + Because of the way [end_borrow] is implemented, when giving back the borrow + [l0] upon evaluating [move y], we won't notice that [shared_borrow l0] has + disappeared from the environment (it has been moved and not assigned yet, + and so is hanging in "thin air"). + + By first "preparing" the operands evaluation, we make sure no such thing + happens. To be more precise, we make sure all the updates to borrows triggered + by access *and* move operations have already been applied. + + Rk.: in the formalization, we always have an explicit "reorganization" step + in the rule premises, before the actual operand evaluation. + + Rk.: doing this is actually not completely necessary because when + generating MIR, rustc introduces intermediate assignments for all the function + parameters. Still, it is better for soundness purposes, and corresponds to + what we do in the formalization (because we don't enforce constraints + in the formalization). + *) +let prepare_eval_operand_reorganize (config : C.config) (op : E.operand) : + cm_fun = + fun cf ctx -> + let prepare : cm_fun = + fun cf ctx -> + match op with + | Expressions.Constant (ty, cv) -> + (* No need to reorganize the context *) + constant_to_typed_value ty cv |> ignore; + cf ctx + | Expressions.Copy p -> + (* Access the value *) + let access = Read in + (* Expand the symbolic values, if necessary *) + let expand_prim_copy = true in + access_rplace_reorganize config expand_prim_copy access p cf ctx + | Expressions.Move p -> + (* Access the value *) + let access = Move in + let expand_prim_copy = false in + access_rplace_reorganize config expand_prim_copy access p cf ctx + in + (* Apply *) + prepare cf ctx + +(** Evaluate an operand, without reorganizing the context before *) +let eval_operand_no_reorganize (config : C.config) (op : E.operand) + (cf : V.typed_value -> m_fun) : m_fun = + fun ctx -> + (* Debug *) + log#ldebug + (lazy + ("eval_operand_no_reorganize: op: " ^ operand_to_string ctx op + ^ "\n- ctx:\n" ^ eval_ctx_to_string ctx ^ "\n")); + (* Evaluate *) + match op with + | Expressions.Constant (ty, cv) -> cf (constant_to_typed_value ty cv) ctx + | Expressions.Copy p -> + (* Access the value *) + let access = Read in + let cc = read_place config access p in + (* Copy the value *) + let copy cf v : m_fun = + fun ctx -> + (* Sanity checks *) + assert (not (bottom_in_value ctx.ended_regions v)); + assert ( + Option.is_none + (find_first_primitively_copyable_sv_with_borrows + ctx.type_context.type_infos v)); + (* Actually perform the copy *) + let allow_adt_copy = false in + let ctx, v = copy_value allow_adt_copy config ctx v in + (* Continue *) + cf v ctx + in + (* Compose and apply *) + comp cc copy cf ctx + | Expressions.Move p -> + (* Access the value *) + let access = Move in + let cc = read_place config access p in + (* Move the value *) + let move cf v : m_fun = + fun ctx -> + (* Check that there are no bottoms in the value we are about to move *) + assert (not (bottom_in_value ctx.ended_regions v)); + let bottom : V.typed_value = { V.value = Bottom; ty = v.ty } in + match write_place config access p bottom ctx with + | Error _ -> failwith "Unreachable" + | Ok ctx -> cf v ctx + in + (* Compose and apply *) + comp cc move cf ctx + +(** Evaluate an operand. + + Reorganize the context, then evaluate the operand. + + **Warning**: this function shouldn't be used to evaluate a list of + operands (for a function call, for instance): we must do *one* reorganization + of the environment, before evaluating all the operands at once. + Use [eval_operands] instead. + *) +let eval_operand (config : C.config) (op : E.operand) + (cf : V.typed_value -> m_fun) : m_fun = + fun ctx -> + (* Debug *) + log#ldebug + (lazy + ("eval_operand: op: " ^ operand_to_string ctx op ^ "\n- ctx:\n" + ^ eval_ctx_to_string ctx ^ "\n")); + (* We reorganize the context, then evaluate the operand *) + comp + (prepare_eval_operand_reorganize config op) + (eval_operand_no_reorganize config op) + cf ctx + +(** Small utility. + + See [prepare_eval_operand_reorganize]. + *) +let prepare_eval_operands_reorganize (config : C.config) (ops : E.operand list) + : cm_fun = + fold_left_apply_continuation (prepare_eval_operand_reorganize config) ops + +(** Evaluate several operands. *) +let eval_operands (config : C.config) (ops : E.operand list) + (cf : V.typed_value list -> m_fun) : m_fun = + fun ctx -> + (* Prepare the operands *) + let prepare = prepare_eval_operands_reorganize config ops in + (* Evaluate the operands *) + let eval = + fold_left_list_apply_continuation (eval_operand_no_reorganize config) ops + in + (* Compose and apply *) + comp prepare eval cf ctx + +let eval_two_operands (config : C.config) (op1 : E.operand) (op2 : E.operand) + (cf : V.typed_value * V.typed_value -> m_fun) : m_fun = + let eval_op = eval_operands config [ op1; op2 ] in + let use_res cf res = + match res with [ v1; v2 ] -> cf (v1, v2) | _ -> failwith "Unreachable" + in + comp eval_op use_res cf + +let eval_unary_op_concrete (config : C.config) (unop : E.unop) (op : E.operand) + (cf : (V.typed_value, eval_error) result -> m_fun) : m_fun = + (* Evaluate the operand *) + let eval_op = eval_operand config op in + (* Apply the unop *) + let apply cf (v : V.typed_value) : m_fun = + match (unop, v.V.value) with + | E.Not, V.Concrete (Bool b) -> + cf (Ok { v with V.value = V.Concrete (Bool (not b)) }) + | E.Neg, V.Concrete (V.Scalar sv) -> ( + let i = Z.neg sv.V.value in + match mk_scalar sv.int_ty i with + | Error _ -> cf (Error EPanic) + | Ok sv -> cf (Ok { v with V.value = V.Concrete (V.Scalar sv) })) + | E.Cast (src_ty, tgt_ty), V.Concrete (V.Scalar sv) -> ( + assert (src_ty == sv.int_ty); + let i = sv.V.value in + match mk_scalar tgt_ty i with + | Error _ -> cf (Error EPanic) + | Ok sv -> + let ty = T.Integer tgt_ty in + let value = V.Concrete (V.Scalar sv) in + cf (Ok { V.ty; value })) + | _ -> raise (Failure "Invalid input for unop") + in + comp eval_op apply cf + +let eval_unary_op_symbolic (config : C.config) (unop : E.unop) (op : E.operand) + (cf : (V.typed_value, eval_error) result -> m_fun) : m_fun = + fun ctx -> + (* Evaluate the operand *) + let eval_op = eval_operand config op in + (* Generate a fresh symbolic value to store the result *) + let apply cf (v : V.typed_value) : m_fun = + fun ctx -> + let res_sv_id = C.fresh_symbolic_value_id () in + let res_sv_ty = + match (unop, v.V.ty) with + | E.Not, T.Bool -> T.Bool + | E.Neg, T.Integer int_ty -> T.Integer int_ty + | E.Cast (_, tgt_ty), _ -> T.Integer tgt_ty + | _ -> raise (Failure "Invalid input for unop") + in + let res_sv = + { V.sv_kind = V.FunCallRet; V.sv_id = res_sv_id; sv_ty = res_sv_ty } + in + (* Call the continuation *) + let expr = cf (Ok (mk_typed_value_from_symbolic_value res_sv)) ctx in + (* Synthesize the symbolic AST *) + S.synthesize_unary_op unop v + (S.mk_opt_place_from_op op ctx) + res_sv None expr + in + (* Compose and apply *) + comp eval_op apply cf ctx + +let eval_unary_op (config : C.config) (unop : E.unop) (op : E.operand) + (cf : (V.typed_value, eval_error) result -> m_fun) : m_fun = + match config.mode with + | C.ConcreteMode -> eval_unary_op_concrete config unop op cf + | C.SymbolicMode -> eval_unary_op_symbolic config unop op cf + +(** Small helper for [eval_binary_op_concrete]: computes the result of applying + the binop *after* the operands have been successfully evaluated + *) +let eval_binary_op_concrete_compute (binop : E.binop) (v1 : V.typed_value) + (v2 : V.typed_value) : (V.typed_value, eval_error) result = + (* Equality check binops (Eq, Ne) accept values from a wide variety of types. + * The remaining binops only operate on scalars. *) + if binop = Eq || binop = Ne then ( + (* Equality operations *) + assert (v1.ty = v2.ty); + (* Equality/inequality check is primitive only for a subset of types *) + assert (ty_is_primitively_copyable v1.ty); + let b = v1 = v2 in + Ok { V.value = V.Concrete (Bool b); ty = T.Bool }) + else + (* For the non-equality operations, the input values are necessarily scalars *) + match (v1.V.value, v2.V.value) with + | V.Concrete (V.Scalar sv1), V.Concrete (V.Scalar sv2) -> ( + (* There are binops which require the two operands to have the same + type, and binops for which it is not the case. + There are also binops which return booleans, and binops which + return integers. + *) + match binop with + | E.Lt | E.Le | E.Ge | E.Gt -> + (* The two operands must have the same type and the result is a boolean *) + assert (sv1.int_ty = sv2.int_ty); + let b = + match binop with + | E.Lt -> Z.lt sv1.V.value sv2.V.value + | E.Le -> Z.leq sv1.V.value sv2.V.value + | E.Ge -> Z.geq sv1.V.value sv2.V.value + | E.Gt -> Z.gt sv1.V.value sv2.V.value + | E.Div | E.Rem | E.Add | E.Sub | E.Mul | E.BitXor | E.BitAnd + | E.BitOr | E.Shl | E.Shr | E.Ne | E.Eq -> + raise (Failure "Unreachable") + in + Ok ({ V.value = V.Concrete (Bool b); ty = T.Bool } : V.typed_value) + | E.Div | E.Rem | E.Add | E.Sub | E.Mul | E.BitXor | E.BitAnd | E.BitOr + -> ( + (* The two operands must have the same type and the result is an integer *) + assert (sv1.int_ty = sv2.int_ty); + let res = + match binop with + | E.Div -> + if sv2.V.value = Z.zero then Error () + else mk_scalar sv1.int_ty (Z.div sv1.V.value sv2.V.value) + | E.Rem -> + (* See [https://github.com/ocaml/Zarith/blob/master/z.mli] *) + if sv2.V.value = Z.zero then Error () + else mk_scalar sv1.int_ty (Z.rem sv1.V.value sv2.V.value) + | E.Add -> mk_scalar sv1.int_ty (Z.add sv1.V.value sv2.V.value) + | E.Sub -> mk_scalar sv1.int_ty (Z.sub sv1.V.value sv2.V.value) + | E.Mul -> mk_scalar sv1.int_ty (Z.mul sv1.V.value sv2.V.value) + | E.BitXor -> raise Unimplemented + | E.BitAnd -> raise Unimplemented + | E.BitOr -> raise Unimplemented + | E.Lt | E.Le | E.Ge | E.Gt | E.Shl | E.Shr | E.Ne | E.Eq -> + raise (Failure "Unreachable") + in + match res with + | Error _ -> Error EPanic + | Ok sv -> + Ok + { + V.value = V.Concrete (V.Scalar sv); + ty = Integer sv1.int_ty; + }) + | E.Shl | E.Shr -> raise Unimplemented + | E.Ne | E.Eq -> raise (Failure "Unreachable")) + | _ -> raise (Failure "Invalid inputs for binop") + +let eval_binary_op_concrete (config : C.config) (binop : E.binop) + (op1 : E.operand) (op2 : E.operand) + (cf : (V.typed_value, eval_error) result -> m_fun) : m_fun = + (* Evaluate the operands *) + let eval_ops = eval_two_operands config op1 op2 in + (* Compute the result of the binop *) + let compute cf (res : V.typed_value * V.typed_value) = + let v1, v2 = res in + cf (eval_binary_op_concrete_compute binop v1 v2) + in + (* Compose and apply *) + comp eval_ops compute cf + +let eval_binary_op_symbolic (config : C.config) (binop : E.binop) + (op1 : E.operand) (op2 : E.operand) + (cf : (V.typed_value, eval_error) result -> m_fun) : m_fun = + fun ctx -> + (* Evaluate the operands *) + let eval_ops = eval_two_operands config op1 op2 in + (* Compute the result of applying the binop *) + let compute cf ((v1, v2) : V.typed_value * V.typed_value) : m_fun = + fun ctx -> + (* Generate a fresh symbolic value to store the result *) + let res_sv_id = C.fresh_symbolic_value_id () in + let res_sv_ty = + if binop = Eq || binop = Ne then ( + (* Equality operations *) + assert (v1.ty = v2.ty); + (* Equality/inequality check is primitive only for a subset of types *) + assert (ty_is_primitively_copyable v1.ty); + T.Bool) + else + (* Other operations: input types are integers *) + match (v1.V.ty, v2.V.ty) with + | T.Integer int_ty1, T.Integer int_ty2 -> ( + match binop with + | E.Lt | E.Le | E.Ge | E.Gt -> + assert (int_ty1 = int_ty2); + T.Bool + | E.Div | E.Rem | E.Add | E.Sub | E.Mul | E.BitXor | E.BitAnd + | E.BitOr -> + assert (int_ty1 = int_ty2); + T.Integer int_ty1 + | E.Shl | E.Shr -> raise Unimplemented + | E.Ne | E.Eq -> raise (Failure "Unreachable")) + | _ -> raise (Failure "Invalid inputs for binop") + in + let res_sv = + { V.sv_kind = V.FunCallRet; V.sv_id = res_sv_id; sv_ty = res_sv_ty } + in + (* Call the continuattion *) + let v = mk_typed_value_from_symbolic_value res_sv in + let expr = cf (Ok v) ctx in + (* Synthesize the symbolic AST *) + let p1 = S.mk_opt_place_from_op op1 ctx in + let p2 = S.mk_opt_place_from_op op2 ctx in + S.synthesize_binary_op binop v1 p1 v2 p2 res_sv None expr + in + (* Compose and apply *) + comp eval_ops compute cf ctx + +let eval_binary_op (config : C.config) (binop : E.binop) (op1 : E.operand) + (op2 : E.operand) (cf : (V.typed_value, eval_error) result -> m_fun) : m_fun + = + match config.mode with + | C.ConcreteMode -> eval_binary_op_concrete config binop op1 op2 cf + | C.SymbolicMode -> eval_binary_op_symbolic config binop op1 op2 cf + +(** Evaluate the discriminant of a concrete (i.e., non symbolic) ADT value *) +let eval_rvalue_discriminant_concrete (config : C.config) (p : E.place) + (cf : V.typed_value -> m_fun) : m_fun = + (* Note that discriminant values have type [isize] *) + (* Access the value *) + let access = Read in + let expand_prim_copy = false in + let prepare = + access_rplace_reorganize_and_read config expand_prim_copy access p + in + (* Read the value *) + let read (cf : V.typed_value -> m_fun) (v : V.typed_value) : m_fun = + (* The value may be shared: we need to ignore the shared loans *) + let v = value_strip_shared_loans v in + match v.V.value with + | Adt av -> ( + match av.variant_id with + | None -> + raise + (Failure + "Invalid input for `discriminant`: structure instead of enum") + | Some variant_id -> ( + let id = Z.of_int (T.VariantId.to_int variant_id) in + match mk_scalar Isize id with + | Error _ -> raise (Failure "Disciminant id out of range") + (* Should really never happen *) + | Ok sv -> + cf { V.value = V.Concrete (V.Scalar sv); ty = Integer Isize })) + | _ -> + raise + (Failure ("Invalid input for `discriminant`: " ^ V.show_typed_value v)) + in + (* Compose and apply *) + comp prepare read cf + +(** Evaluate the discriminant of an ADT value. + + Might lead to branching, if the value is symbolic. + *) +let eval_rvalue_discriminant (config : C.config) (p : E.place) + (cf : V.typed_value -> m_fun) : m_fun = + fun ctx -> + log#ldebug (lazy "eval_rvalue_discriminant"); + (* Note that discriminant values have type [isize] *) + (* Access the value *) + let access = Read in + let expand_prim_copy = false in + let prepare = + access_rplace_reorganize_and_read config expand_prim_copy access p + in + (* Read the value *) + let read (cf : V.typed_value -> m_fun) (v : V.typed_value) : m_fun = + fun ctx -> + (* The value may be shared: we need to ignore the shared loans *) + let v = value_strip_shared_loans v in + match v.V.value with + | Adt _ -> eval_rvalue_discriminant_concrete config p cf ctx + | Symbolic sv -> + (* Expand the symbolic value - may lead to branching *) + let allow_branching = true in + let cc = + expand_symbolic_value config allow_branching sv + (Some (S.mk_mplace p ctx)) + in + (* This time the value is concrete: reevaluate *) + comp cc (eval_rvalue_discriminant_concrete config p) cf ctx + | _ -> + raise + (Failure ("Invalid input for `discriminant`: " ^ V.show_typed_value v)) + in + (* Compose and apply *) + comp prepare read cf ctx + +let eval_rvalue_ref (config : C.config) (p : E.place) (bkind : E.borrow_kind) + (cf : V.typed_value -> m_fun) : m_fun = + fun ctx -> + match bkind with + | E.Shared | E.TwoPhaseMut -> + (* Access the value *) + let access = if bkind = E.Shared then Read else Write in + let expand_prim_copy = false in + let prepare = + access_rplace_reorganize_and_read config expand_prim_copy access p + in + (* Evaluate the borrowing operation *) + let eval (cf : V.typed_value -> m_fun) (v : V.typed_value) : m_fun = + fun ctx -> + (* Generate the fresh borrow id *) + let bid = C.fresh_borrow_id () in + (* Compute the loan value, with which to replace the value at place p *) + let nv, shared_mvalue = + match v.V.value with + | V.Loan (V.SharedLoan (bids, sv)) -> + (* Shared loan: insert the new borrow id *) + let bids1 = V.BorrowId.Set.add bid bids in + ({ v with V.value = V.Loan (V.SharedLoan (bids1, sv)) }, sv) + | _ -> + (* Not a shared loan: add a wrapper *) + let v' = + V.Loan (V.SharedLoan (V.BorrowId.Set.singleton bid, v)) + in + ({ v with V.value = v' }, v) + in + (* Update the borrowed value in the context *) + let ctx = write_place_unwrap config access p nv ctx in + (* Compute the rvalue - simply a shared borrow with a the fresh id. + * Note that the reference is *mutable* if we do a two-phase borrow *) + let rv_ty = + T.Ref (T.Erased, v.ty, if bkind = E.Shared then Shared else Mut) + in + let bc = + if bkind = E.Shared then V.SharedBorrow (shared_mvalue, bid) + else V.InactivatedMutBorrow (shared_mvalue, bid) + in + let rv : V.typed_value = { V.value = V.Borrow bc; ty = rv_ty } in + (* Continue *) + cf rv ctx + in + (* Compose and apply *) + comp prepare eval cf ctx + | E.Mut -> + (* Access the value *) + let access = Write in + let expand_prim_copy = false in + let prepare = + access_rplace_reorganize_and_read config expand_prim_copy access p + in + (* Evaluate the borrowing operation *) + let eval (cf : V.typed_value -> m_fun) (v : V.typed_value) : m_fun = + fun ctx -> + (* Compute the rvalue - wrap the value in a mutable borrow with a fresh id *) + let bid = C.fresh_borrow_id () in + let rv_ty = T.Ref (T.Erased, v.ty, Mut) in + let rv : V.typed_value = + { V.value = V.Borrow (V.MutBorrow (bid, v)); ty = rv_ty } + in + (* Compute the value with which to replace the value at place p *) + let nv = { v with V.value = V.Loan (V.MutLoan bid) } in + (* Update the value in the context *) + let ctx = write_place_unwrap config access p nv ctx in + (* Continue *) + cf rv ctx + in + (* Compose and apply *) + comp prepare eval cf ctx + +let eval_rvalue_aggregate (config : C.config) + (aggregate_kind : E.aggregate_kind) (ops : E.operand list) + (cf : V.typed_value -> m_fun) : m_fun = + (* Evaluate the operands *) + let eval_ops = eval_operands config ops in + (* Compute the value *) + let compute (cf : V.typed_value -> m_fun) (values : V.typed_value list) : + m_fun = + fun ctx -> + (* Match on the aggregate kind *) + match aggregate_kind with + | E.AggregatedTuple -> + let tys = List.map (fun (v : V.typed_value) -> v.V.ty) values in + let v = V.Adt { variant_id = None; field_values = values } in + let ty = T.Adt (T.Tuple, [], tys) in + let aggregated : V.typed_value = { V.value = v; ty } in + (* Call the continuation *) + cf aggregated ctx + | E.AggregatedOption (variant_id, ty) -> + (* Sanity check *) + if variant_id == T.option_none_id then assert (values == []) + else if variant_id == T.option_some_id then + assert (List.length values == 1) + else raise (Failure "Unreachable"); + (* Construt the value *) + let aty = T.Adt (T.Assumed T.Option, [], [ ty ]) in + let av : V.adt_value = + { V.variant_id = Some variant_id; V.field_values = values } + in + let aggregated : V.typed_value = { V.value = Adt av; ty = aty } in + (* Call the continuation *) + cf aggregated ctx + | E.AggregatedAdt (def_id, opt_variant_id, regions, types) -> + (* Sanity checks *) + let type_decl = C.ctx_lookup_type_decl ctx def_id in + assert (List.length type_decl.region_params = List.length regions); + let expected_field_types = + Subst.ctx_adt_get_instantiated_field_etypes ctx def_id opt_variant_id + types + in + assert ( + expected_field_types + = List.map (fun (v : V.typed_value) -> v.V.ty) values); + (* Construct the value *) + let av : V.adt_value = + { V.variant_id = opt_variant_id; V.field_values = values } + in + let aty = T.Adt (T.AdtId def_id, regions, types) in + let aggregated : V.typed_value = { V.value = Adt av; ty = aty } in + (* Call the continuation *) + cf aggregated ctx + in + (* Compose and apply *) + comp eval_ops compute cf + +(** Evaluate an rvalue. + + Transmits the computed rvalue to the received continuation. + *) +let eval_rvalue (config : C.config) (rvalue : E.rvalue) + (cf : (V.typed_value, eval_error) result -> m_fun) : m_fun = + fun ctx -> + log#ldebug (lazy "eval_rvalue"); + (* Small helpers *) + let wrap_in_result (cf : (V.typed_value, eval_error) result -> m_fun) + (v : V.typed_value) : m_fun = + cf (Ok v) + in + let comp_wrap f = comp f wrap_in_result cf in + (* Delegate to the proper auxiliary function *) + match rvalue with + | E.Use op -> comp_wrap (eval_operand config op) ctx + | E.Ref (p, bkind) -> comp_wrap (eval_rvalue_ref config p bkind) ctx + | E.UnaryOp (unop, op) -> eval_unary_op config unop op cf ctx + | E.BinaryOp (binop, op1, op2) -> eval_binary_op config binop op1 op2 cf ctx + | E.Aggregate (aggregate_kind, ops) -> + comp_wrap (eval_rvalue_aggregate config aggregate_kind ops) ctx + | E.Discriminant p -> comp_wrap (eval_rvalue_discriminant config p) ctx diff --git a/compiler/InterpreterPaths.ml b/compiler/InterpreterPaths.ml new file mode 100644 index 00000000..d54a046e --- /dev/null +++ b/compiler/InterpreterPaths.ml @@ -0,0 +1,801 @@ +module T = Types +module V = Values +module E = Expressions +module C = Contexts +module Subst = Substitute +module L = Logging +open Cps +open TypesUtils +open ValuesUtils +open InterpreterUtils +open InterpreterBorrowsCore +open InterpreterBorrows +open InterpreterExpansion +module Synth = SynthesizeSymbolic + +(** The local logger *) +let log = L.paths_log + +(** Paths *) + +(** When we fail reading from or writing to a path, it might be because we + need to update the environment by ending borrows, expanding symbolic + values, etc. The following type is used to convey this information. + + TODO: compare with borrow_lres? +*) +type path_fail_kind = + | FailSharedLoan of V.BorrowId.Set.t + (** Failure because we couldn't go inside a shared loan *) + | FailMutLoan of V.BorrowId.id + (** Failure because we couldn't go inside a mutable loan *) + | FailInactivatedMutBorrow of V.BorrowId.id + (** Failure because we couldn't go inside an inactivated mutable borrow + (which should get activated) *) + | FailSymbolic of int * V.symbolic_value + (** Failure because we need to enter a symbolic value (and thus need to + expand it). + We return the number of elements which remained in the path when we + reached the error - this allows to retrieve the path prefix, which + is useful for the synthesis. *) + | FailBottom of int * E.projection_elem * T.ety + (** Failure because we need to enter an any value - we can expand Bottom + values if they are left values. We return the number of elements which + remained in the path when we reached the error - this allows to + properly update the Bottom value, if needs be. + *) + | FailBorrow of V.borrow_content + (** We got stuck because we couldn't enter a borrow *) + +(** Result of evaluating a path (reading from a path/writing to a path) + + Note that when we fail, we return information used to update the + environment, as well as the +*) +type 'a path_access_result = ('a, path_fail_kind) result +(** The result of reading from/writing to a place *) + +type updated_read_value = { read : V.typed_value; updated : V.typed_value } + +type projection_access = { + enter_shared_loans : bool; + enter_mut_borrows : bool; + lookup_shared_borrows : bool; +} + +(** Generic function to access (read/write) the value at the end of a projection. + + We return the (eventually) updated value, the value we read at the end of + the place and the (eventually) updated environment. + + TODO: use exceptions? + *) +let rec access_projection (access : projection_access) (ctx : C.eval_ctx) + (* Function to (eventually) update the value we find *) + (update : V.typed_value -> V.typed_value) (p : E.projection) + (v : V.typed_value) : (C.eval_ctx * updated_read_value) path_access_result = + (* For looking up/updating shared loans *) + let ek : exploration_kind = + { enter_shared_loans = true; enter_mut_borrows = true; enter_abs = true } + in + match p with + | [] -> + let nv = update v in + (* Type checking *) + if nv.ty <> v.ty then ( + log#lerror + (lazy + ("Not the same type:\n- nv.ty: " ^ T.show_ety nv.ty ^ "\n- v.ty: " + ^ T.show_ety v.ty)); + failwith + "Assertion failed: new value doesn't have the same type as its \ + destination"); + Ok (ctx, { read = v; updated = nv }) + | pe :: p' -> ( + (* Match on the projection element and the value *) + match (pe, v.V.value, v.V.ty) with + | ( Field (((ProjAdt (_, _) | ProjOption _) as proj_kind), field_id), + V.Adt adt, + T.Adt (type_id, _, _) ) -> ( + (* Check consistency *) + (match (proj_kind, type_id) with + | ProjAdt (def_id, opt_variant_id), T.AdtId def_id' -> + assert (def_id = def_id'); + assert (opt_variant_id = adt.variant_id) + | ProjOption variant_id, T.Assumed T.Option -> + assert (Some variant_id = adt.variant_id) + | _ -> failwith "Unreachable"); + (* Actually project *) + let fv = T.FieldId.nth adt.field_values field_id in + match access_projection access ctx update p' fv with + | Error err -> Error err + | Ok (ctx, res) -> + (* Update the field value *) + let nvalues = + T.FieldId.update_nth adt.field_values field_id res.updated + in + let nadt = V.Adt { adt with V.field_values = nvalues } in + let updated = { v with value = nadt } in + Ok (ctx, { res with updated })) + (* Tuples *) + | Field (ProjTuple arity, field_id), V.Adt adt, T.Adt (T.Tuple, _, _) -> ( + assert (arity = List.length adt.field_values); + let fv = T.FieldId.nth adt.field_values field_id in + (* Project *) + match access_projection access ctx update p' fv with + | Error err -> Error err + | Ok (ctx, res) -> + (* Update the field value *) + let nvalues = + T.FieldId.update_nth adt.field_values field_id res.updated + in + let ntuple = V.Adt { adt with field_values = nvalues } in + let updated = { v with value = ntuple } in + Ok (ctx, { res with updated }) + (* If we reach Bottom, it may mean we need to expand an uninitialized + * enumeration value *)) + | Field ((ProjAdt (_, _) | ProjTuple _ | ProjOption _), _), V.Bottom, _ -> + Error (FailBottom (1 + List.length p', pe, v.ty)) + (* Symbolic value: needs to be expanded *) + | _, Symbolic sp, _ -> + (* Expand the symbolic value *) + Error (FailSymbolic (1 + List.length p', sp)) + (* Box dereferencement *) + | ( DerefBox, + Adt { variant_id = None; field_values = [ bv ] }, + T.Adt (T.Assumed T.Box, _, _) ) -> ( + (* We allow moving inside of boxes. In practice, this kind of + * manipulations should happen only inside unsage code, so + * it shouldn't happen due to user code, and we leverage it + * when implementing box dereferencement for the concrete + * interpreter *) + match access_projection access ctx update p' bv with + | Error err -> Error err + | Ok (ctx, res) -> + let nv = + { + v with + value = + V.Adt { variant_id = None; field_values = [ res.updated ] }; + } + in + Ok (ctx, { res with updated = nv })) + (* Borrows *) + | Deref, V.Borrow bc, _ -> ( + match bc with + | V.SharedBorrow (_, bid) -> + (* Lookup the loan content, and explore from there *) + if access.lookup_shared_borrows then + match lookup_loan ek bid ctx with + | _, Concrete (V.MutLoan _) -> failwith "Expected a shared loan" + | _, Concrete (V.SharedLoan (bids, sv)) -> ( + (* Explore the shared value *) + match access_projection access ctx update p' sv with + | Error err -> Error err + | Ok (ctx, res) -> + (* Update the shared loan with the new value returned + by {!access_projection} *) + let ctx = + update_loan ek bid + (V.SharedLoan (bids, res.updated)) + ctx + in + (* Return - note that we don't need to update the borrow itself *) + Ok (ctx, { res with updated = v })) + | ( _, + Abstract + ( V.AMutLoan (_, _) + | V.AEndedMutLoan + { given_back = _; child = _; given_back_meta = _ } + | V.AEndedSharedLoan (_, _) + | V.AIgnoredMutLoan (_, _) + | V.AEndedIgnoredMutLoan + { given_back = _; child = _; given_back_meta = _ } + | V.AIgnoredSharedLoan _ ) ) -> + failwith "Expected a shared (abstraction) loan" + | _, Abstract (V.ASharedLoan (bids, sv, _av)) -> ( + (* Explore the shared value *) + match access_projection access ctx update p' sv with + | Error err -> Error err + | Ok (ctx, res) -> + (* Relookup the child avalue *) + let av = + match lookup_loan ek bid ctx with + | _, Abstract (V.ASharedLoan (_, _, av)) -> av + | _ -> failwith "Unexpected" + in + (* Update the shared loan with the new value returned + by {!access_projection} *) + let ctx = + update_aloan ek bid + (V.ASharedLoan (bids, res.updated, av)) + ctx + in + (* Return - note that we don't need to update the borrow itself *) + Ok (ctx, { res with updated = v })) + else Error (FailBorrow bc) + | V.InactivatedMutBorrow (_, bid) -> + Error (FailInactivatedMutBorrow bid) + | V.MutBorrow (bid, bv) -> + if access.enter_mut_borrows then + match access_projection access ctx update p' bv with + | Error err -> Error err + | Ok (ctx, res) -> + let nv = + { + v with + value = V.Borrow (V.MutBorrow (bid, res.updated)); + } + in + Ok (ctx, { res with updated = nv }) + else Error (FailBorrow bc)) + | _, V.Loan lc, _ -> ( + match lc with + | V.MutLoan bid -> Error (FailMutLoan bid) + | V.SharedLoan (bids, sv) -> + (* If we can enter shared loan, we ignore the loan. Pay attention + to the fact that we need to reexplore the *whole* place (i.e, + we mustn't ignore the current projection element *) + if access.enter_shared_loans then + match access_projection access ctx update (pe :: p') sv with + | Error err -> Error err + | Ok (ctx, res) -> + let nv = + { + v with + value = V.Loan (V.SharedLoan (bids, res.updated)); + } + in + Ok (ctx, { res with updated = nv }) + else Error (FailSharedLoan bids)) + | (_, (V.Concrete _ | V.Adt _ | V.Bottom | V.Borrow _), _) as r -> + let pe, v, ty = r in + let pe = "- pe: " ^ E.show_projection_elem pe in + let v = "- v:\n" ^ V.show_value v in + let ty = "- ty:\n" ^ T.show_ety ty in + log#serror ("Inconsistent projection:\n" ^ pe ^ "\n" ^ v ^ "\n" ^ ty); + failwith "Inconsistent projection") + +(** Generic function to access (read/write) the value at a given place. + + We return the value we read at the place and the (eventually) updated + environment, if we managed to access the place, or the precise reason + why we failed. + *) +let access_place (access : projection_access) + (* Function to (eventually) update the value we find *) + (update : V.typed_value -> V.typed_value) (p : E.place) (ctx : C.eval_ctx) + : (C.eval_ctx * V.typed_value) path_access_result = + (* Lookup the variable's value *) + let value = C.ctx_lookup_var_value ctx p.var_id in + (* Apply the projection *) + match access_projection access ctx update p.projection value with + | Error err -> Error err + | Ok (ctx, res) -> + (* Update the value *) + let ctx = C.ctx_update_var_value ctx p.var_id res.updated in + (* Return *) + Ok (ctx, res.read) + +type access_kind = + | Read (** We can go inside borrows and loans *) + | Write (** Don't enter shared borrows or shared loans *) + | Move (** Don't enter borrows or loans *) + +let access_kind_to_projection_access (access : access_kind) : projection_access + = + match access with + | Read -> + { + enter_shared_loans = true; + enter_mut_borrows = true; + lookup_shared_borrows = true; + } + | Write -> + { + enter_shared_loans = false; + enter_mut_borrows = true; + lookup_shared_borrows = false; + } + | Move -> + { + enter_shared_loans = false; + enter_mut_borrows = false; + lookup_shared_borrows = false; + } + +(** Read the value at a given place. + + Note that we only access the value at the place, and do not check that + the value is "well-formed" (for instance that it doesn't contain bottoms). + *) +let read_place (config : C.config) (access : access_kind) (p : E.place) + (ctx : C.eval_ctx) : V.typed_value path_access_result = + let access = access_kind_to_projection_access access in + (* The update function is the identity *) + let update v = v in + match access_place access update p ctx with + | Error err -> Error err + | Ok (ctx1, read_value) -> + (* Note that we ignore the new environment: it should be the same as the + original one. + *) + if config.check_invariants then + if ctx1 <> ctx then ( + let msg = + "Unexpected environment update:\nNew environment:\n" + ^ C.show_env ctx1.env ^ "\n\nOld environment:\n" + ^ C.show_env ctx.env + in + log#serror msg; + failwith "Unexpected environment update"); + Ok read_value + +let read_place_unwrap (config : C.config) (access : access_kind) (p : E.place) + (ctx : C.eval_ctx) : V.typed_value = + match read_place config access p ctx with + | Error _ -> failwith "Unreachable" + | Ok v -> v + +(** Update the value at a given place *) +let write_place (_config : C.config) (access : access_kind) (p : E.place) + (nv : V.typed_value) (ctx : C.eval_ctx) : C.eval_ctx path_access_result = + let access = access_kind_to_projection_access access in + (* The update function substitutes the value with the new value *) + let update _ = nv in + match access_place access update p ctx with + | Error err -> Error err + | Ok (ctx, _) -> + (* We ignore the read value *) + Ok ctx + +let write_place_unwrap (config : C.config) (access : access_kind) (p : E.place) + (nv : V.typed_value) (ctx : C.eval_ctx) : C.eval_ctx = + match write_place config access p nv ctx with + | Error _ -> failwith "Unreachable" + | Ok ctx -> ctx + +(** Compute an expanded ADT bottom value *) +let compute_expanded_bottom_adt_value (tyctx : T.type_decl T.TypeDeclId.Map.t) + (def_id : T.TypeDeclId.id) (opt_variant_id : T.VariantId.id option) + (regions : T.erased_region list) (types : T.ety list) : V.typed_value = + (* Lookup the definition and check if it is an enumeration - it + should be an enumeration if and only if the projection element + is a field projection with *some* variant id. Retrieve the list + of fields at the same time. *) + let def = T.TypeDeclId.Map.find def_id tyctx in + assert (List.length regions = List.length def.T.region_params); + (* Compute the field types *) + let field_types = + Subst.type_decl_get_instantiated_field_etypes def opt_variant_id types + in + (* Initialize the expanded value *) + let fields = List.map mk_bottom field_types in + let av = V.Adt { variant_id = opt_variant_id; field_values = fields } in + let ty = T.Adt (T.AdtId def_id, regions, types) in + { V.value = av; V.ty } + +(** Compute an expanded Option bottom value *) +let compute_expanded_bottom_option_value (variant_id : T.VariantId.id) + (param_ty : T.ety) : V.typed_value = + (* Note that the variant can be [Some] or [None]: we expand bottom values + * when writing to fields or setting discriminants *) + let field_values = + if variant_id = T.option_some_id then [ mk_bottom param_ty ] + else if variant_id = T.option_none_id then [] + else raise (Failure "Unreachable") + in + let av = V.Adt { variant_id = Some variant_id; field_values } in + let ty = T.Adt (T.Assumed T.Option, [], [ param_ty ]) in + { V.value = av; ty } + +(** Compute an expanded tuple bottom value *) +let compute_expanded_bottom_tuple_value (field_types : T.ety list) : + V.typed_value = + (* Generate the field values *) + let fields = List.map mk_bottom field_types in + let v = V.Adt { variant_id = None; field_values = fields } in + let ty = T.Adt (T.Tuple, [], field_types) in + { V.value = v; V.ty } + +(** Auxiliary helper to expand {!V.Bottom} values. + + During compilation, rustc desaggregates the ADT initializations. The + consequence is that the following rust code: + {[ + let x = Cons a b; + ]} + + Looks like this in MIR: + {[ + (x as Cons).0 = a; + (x as Cons).1 = b; + set_discriminant(x, 0); // If [Cons] is the variant of index 0 + ]} + + The consequence is that we may sometimes need to write fields to values + which are currently {!V.Bottom}. When doing this, we first expand the value + to, say, [Cons Bottom Bottom] (note that field projection contains information + about which variant we should project to, which is why we *can* set the + variant index when writing one of its fields). +*) +let expand_bottom_value_from_projection (config : C.config) + (access : access_kind) (p : E.place) (remaining_pes : int) + (pe : E.projection_elem) (ty : T.ety) (ctx : C.eval_ctx) : C.eval_ctx = + (* Debugging *) + log#ldebug + (lazy + ("expand_bottom_value_from_projection:\n" ^ "pe: " + ^ E.show_projection_elem pe ^ "\n" ^ "ty: " ^ T.show_ety ty)); + (* Prepare the update: we need to take the proper prefix of the place + during whose evaluation we got stuck *) + let projection' = + fst + (Collections.List.split_at p.projection + (List.length p.projection - remaining_pes)) + in + let p' = { p with projection = projection' } in + (* Compute the expanded value. + The type of the {!V.Bottom} value should be a tuple or an ADT. + Note that the projection element we got stuck at should be a + field projection, and gives the variant id if the {!V.Bottom} value + is an enumeration value. + Also, the expanded value should be the proper ADT variant or a tuple + with the proper arity, with all the fields initialized to {!V.Bottom} + *) + let nv = + match (pe, ty) with + (* "Regular" ADTs *) + | ( Field (ProjAdt (def_id, opt_variant_id), _), + T.Adt (T.AdtId def_id', regions, types) ) -> + assert (def_id = def_id'); + compute_expanded_bottom_adt_value ctx.type_context.type_decls def_id + opt_variant_id regions types + (* Option *) + | Field (ProjOption variant_id, _), T.Adt (T.Assumed T.Option, [], [ ty ]) + -> + compute_expanded_bottom_option_value variant_id ty + (* Tuples *) + | Field (ProjTuple arity, _), T.Adt (T.Tuple, [], tys) -> + assert (arity = List.length tys); + (* Generate the field values *) + compute_expanded_bottom_tuple_value tys + | _ -> + failwith + ("Unreachable: " ^ E.show_projection_elem pe ^ ", " ^ T.show_ety ty) + in + (* Update the context by inserting the expanded value at the proper place *) + match write_place config access p' nv ctx with + | Ok ctx -> ctx + | Error _ -> failwith "Unreachable" + +(** Update the environment to be able to read a place. + + When reading a place, we may be stuck along the way because some value + is borrowed, we reach a symbolic value, etc. In this situation [read_place] + fails while returning precise information about the failure. This function + uses this information to update the environment (by ending borrows, + expanding symbolic values) until we manage to fully read the place. + *) +let rec update_ctx_along_read_place (config : C.config) (access : access_kind) + (p : E.place) : cm_fun = + fun cf ctx -> + (* Attempt to read the place: if it fails, update the environment and retry *) + match read_place config access p ctx with + | Ok _ -> cf ctx + | Error err -> + let cc = + match err with + | FailSharedLoan bids -> end_outer_borrows config bids + | FailMutLoan bid -> end_outer_borrow config bid + | FailInactivatedMutBorrow bid -> + activate_inactivated_mut_borrow config bid + | FailSymbolic (i, sp) -> + (* Expand the symbolic value *) + let proj, _ = + Collections.List.split_at p.projection + (List.length p.projection - i) + in + let prefix = { p with projection = proj } in + expand_symbolic_value_no_branching config sp + (Some (Synth.mk_mplace prefix ctx)) + | FailBottom (_, _, _) -> + (* We can't expand {!V.Bottom} values while reading them *) + failwith "Found [Bottom] while reading a place" + | FailBorrow _ -> failwith "Could not read a borrow" + in + comp cc (update_ctx_along_read_place config access p) cf ctx + +(** Update the environment to be able to write to a place. + + See {!update_ctx_along_read_place}. +*) +let rec update_ctx_along_write_place (config : C.config) (access : access_kind) + (p : E.place) : cm_fun = + fun cf ctx -> + (* Attempt to *read* (yes, *read*: we check the access to the place, and + write to it later) the place: if it fails, update the environment and retry *) + match read_place config access p ctx with + | Ok _ -> cf ctx + | Error err -> + (* Update the context *) + let cc = + match err with + | FailSharedLoan bids -> end_outer_borrows config bids + | FailMutLoan bid -> end_outer_borrow config bid + | FailInactivatedMutBorrow bid -> + activate_inactivated_mut_borrow config bid + | FailSymbolic (_pe, sp) -> + (* Expand the symbolic value *) + expand_symbolic_value_no_branching config sp + (Some (Synth.mk_mplace p ctx)) + | FailBottom (remaining_pes, pe, ty) -> + (* Expand the {!V.Bottom} value *) + fun cf ctx -> + let ctx = + expand_bottom_value_from_projection config access p remaining_pes + pe ty ctx + in + cf ctx + | FailBorrow _ -> failwith "Could not write to a borrow" + in + (* Retry *) + comp cc (update_ctx_along_write_place config access p) cf ctx + +(** Small utility used to break control-flow *) +exception UpdateCtx of cm_fun + +(** End the loans at a given place: read the value, if it contains a loan, + end this loan, repeat. + + This is used when reading or borrowing values. We typically + first call {!update_ctx_along_read_place} or {!update_ctx_along_write_place} + to get access to the value, then call this function to "prepare" the value: + when moving values, we can't move a value which contains loans and thus need + to end them, etc. + *) +let rec end_loans_at_place (config : C.config) (access : access_kind) + (p : E.place) : cm_fun = + fun cf ctx -> + (* Iterator to explore a value and update the context whenever we find + * loans. + * We use exceptions to make it handy: whenever we update the + * context, we raise an exception wrapping the updated context. + * *) + let obj = + object + inherit [_] V.iter_typed_value as super + + method! visit_borrow_content env bc = + match bc with + | V.SharedBorrow _ | V.MutBorrow (_, _) -> + (* Nothing special to do *) super#visit_borrow_content env bc + | V.InactivatedMutBorrow (_, bid) -> + (* We need to activate inactivated borrows *) + let cc = activate_inactivated_mut_borrow config bid in + raise (UpdateCtx cc) + + method! visit_loan_content env lc = + match lc with + | V.SharedLoan (bids, v) -> ( + (* End the loans if we need a modification access, otherwise dive into + the shared value *) + match access with + | Read -> super#visit_SharedLoan env bids v + | Write | Move -> + let cc = end_outer_borrows config bids in + raise (UpdateCtx cc)) + | V.MutLoan bid -> + (* We always need to end mutable borrows *) + let cc = end_outer_borrow config bid in + raise (UpdateCtx cc) + end + in + + (* First, retrieve the value *) + match read_place config access p ctx with + | Error _ -> failwith "Unreachable" + | Ok v -> ( + (* Inspect the value and update the context while doing so. + If the context gets updated: perform a recursive call (many things + may have been updated in the context: we need to re-read the value + at place [p] - and this value may actually not be accessible + anymore...) + *) + try + obj#visit_typed_value () v; + (* No context update required: apply the continuation *) + cf ctx + with UpdateCtx cc -> + (* We need to update the context: compose the caugth continuation with + * a recursive call to reinspect the value *) + comp cc (end_loans_at_place config access p) cf ctx) + +(** Drop (end) outer loans and borrows at a given place, which should be + seen as an l-value (we will write to it later, but need to drop + the borrows before writing). + + This is used to drop values when evaluating the drop statement or before + writing to a place. + + [end_borrows]: + - if true: end all the loans and borrows we find, starting with the outer + ones. This is used when evaluating the [drop] statement (see [drop_value]) + - if false: only end the outer loans. This is used by [assign_to_place] + or to drop the loans in the local variables when popping a frame. + + Note that we don't do what is defined in the formalization: we move the + value to a temporary dummy value, then explore this value and end the + loans/borrows inside as long as we find some, starting with the outer + ones, then move the resulting value back to where it was. This shouldn't + make any difference, really (note that the place is *inside* a borrow, + if we end the borrow, we won't be able to reinsert the value back). + *) +let drop_outer_borrows_loans_at_lplace (config : C.config) (end_borrows : bool) + (p : E.place) : cm_fun = + fun cf ctx -> + (* Move the current value in the place outside of this place and into + * a dummy variable *) + let access = Write in + let v = read_place_unwrap config access p ctx in + let ctx = write_place_unwrap config access p (mk_bottom v.V.ty) ctx in + let ctx = C.ctx_push_dummy_var ctx v in + (* Auxiliary function *) + let rec drop : cm_fun = + fun cf ctx -> + (* Read the value *) + let v = C.ctx_read_first_dummy_var ctx in + (* Check if there are loans or borrows to end *) + match get_first_outer_loan_or_borrow_in_value end_borrows v with + | None -> + (* We are done: simply call the continuation *) + cf ctx + | Some c -> + (* There are: end them then retry *) + let cc = + match c with + | LoanContent (V.SharedLoan (bids, _)) -> + end_outer_borrows config bids + | LoanContent (V.MutLoan bid) + | BorrowContent (V.MutBorrow (bid, _) | SharedBorrow (_, bid)) -> + end_outer_borrow config bid + | BorrowContent (V.InactivatedMutBorrow (_, bid)) -> + (* First activate the borrow *) + activate_inactivated_mut_borrow config bid + in + (* Retry *) + comp cc drop cf ctx + in + (* Apply the drop function *) + let cc = drop in + (* Pop the temporary value and reinsert it *) + let cc = + comp cc (fun cf ctx -> + (* Pop *) + let ctx, v = C.ctx_pop_dummy_var ctx in + (* Reinsert *) + let ctx = write_place_unwrap config access p v ctx in + (* Sanity check *) + if end_borrows then ( + assert (not (loans_in_value v)); + assert (not (borrows_in_value v))) + else assert (not (outer_loans_in_value v)); + (* Continue *) + cf ctx) + in + (* Continue *) + cc cf ctx + +(** Copy a value, and return the resulting value. + + Note that copying values might update the context. For instance, when + copying shared borrows, we need to insert new shared borrows in the context. + + Also, this function is actually more general than it should be: it can be used + to copy concrete ADT values, while ADT copy should be done through the Copy + trait (i.e., by calling a dedicated function). This is why we added a parameter + to control this copy. Note that here by ADT we mean the user-defined ADTs + (not tuples or assumed types). + + TODO: move + *) +let rec copy_value (allow_adt_copy : bool) (config : C.config) + (ctx : C.eval_ctx) (v : V.typed_value) : C.eval_ctx * V.typed_value = + log#ldebug + (lazy + ("copy_value: " + ^ typed_value_to_string ctx v + ^ "\n- context:\n" ^ eval_ctx_to_string ctx)); + (* Remark: at some point we rewrote this function to use iterators, but then + * we reverted the changes: the result was less clear actually. In particular, + * the fact that we have exhaustive matches below makes very obvious the cases + * in which we need to fail *) + match v.V.value with + | V.Concrete _ -> (ctx, v) + | V.Adt av -> + (* Sanity check *) + (match v.V.ty with + | T.Adt (T.Assumed (T.Box | Vec), _, _) -> + failwith "Can't copy an assumed value other than Option" + | T.Adt (T.AdtId _, _, _) -> assert allow_adt_copy + | T.Adt ((T.Assumed Option | T.Tuple), _, _) -> () (* Ok *) + | _ -> failwith "Unreachable"); + let ctx, fields = + List.fold_left_map + (copy_value allow_adt_copy config) + ctx av.field_values + in + (ctx, { v with V.value = V.Adt { av with field_values = fields } }) + | V.Bottom -> failwith "Can't copy ⊥" + | V.Borrow bc -> ( + (* We can only copy shared borrows *) + match bc with + | SharedBorrow (mv, bid) -> + (* We need to create a new borrow id for the copied borrow, and + * update the context accordingly *) + let bid' = C.fresh_borrow_id () in + let ctx = reborrow_shared bid bid' ctx in + (ctx, { v with V.value = V.Borrow (SharedBorrow (mv, bid')) }) + | MutBorrow (_, _) -> failwith "Can't copy a mutable borrow" + | V.InactivatedMutBorrow _ -> + failwith "Can't copy an inactivated mut borrow") + | V.Loan lc -> ( + (* We can only copy shared loans *) + match lc with + | V.MutLoan _ -> failwith "Can't copy a mutable loan" + | V.SharedLoan (_, sv) -> + (* We don't copy the shared loan: only the shared value inside *) + copy_value allow_adt_copy config ctx sv) + | V.Symbolic sp -> + (* We can copy only if the type is "primitively" copyable. + * Note that in the general case, copy is a trait: copying values + * thus requires calling the proper function. Here, we copy values + * for very simple types such as integers, shared borrows, etc. *) + assert (ty_is_primitively_copyable (Subst.erase_regions sp.V.sv_ty)); + (* If the type is copyable, we simply return the current value. Side + * remark: what is important to look at when copying symbolic values + * is symbolic expansion. The important subcase is the expansion of shared + * borrows: when doing so, every occurrence of the same symbolic value + * must use a fresh borrow id. *) + (ctx, v) + +(** Small utility. + + Prepare a place which is to be used as the destination of an assignment: + update the environment along the paths, end the loans at this place, etc. + + Return the updated context and the (updated) value at the end of the + place. This value should not contain any loan or borrow (and we check + it is the case). Note that this value is very likely to contain {!V.Bottom} + subvalues. + + [end_borrows]: if false, we only end the outer loans we find. If true, we + end all the loans and the borrows we find. + TODO: end_borrows is not necessary anymore. + *) +let prepare_lplace (config : C.config) (end_borrows : bool) (p : E.place) + (cf : V.typed_value -> m_fun) : m_fun = + fun ctx -> + log#ldebug + (lazy + ("prepare_lplace:" ^ "\n- p: " ^ place_to_string ctx p + ^ "\n- Initial context:\n" ^ eval_ctx_to_string ctx)); + (* Access the place *) + let access = Write in + let cc = update_ctx_along_write_place config access p in + (* End the borrows and loans, starting with the borrows *) + let cc = comp cc (drop_outer_borrows_loans_at_lplace config end_borrows p) in + (* Read the value and check it *) + let read_check cf : m_fun = + fun ctx -> + let v = read_place_unwrap config access p ctx in + (* Sanity checks *) + if end_borrows then ( + assert (not (loans_in_value v)); + assert (not (borrows_in_value v))) + else assert (not (outer_loans_in_value v)); + (* Continue *) + cf v ctx + in + (* Compose and apply the continuations *) + comp cc read_check cf ctx diff --git a/compiler/InterpreterProjectors.ml b/compiler/InterpreterProjectors.ml new file mode 100644 index 00000000..064b8969 --- /dev/null +++ b/compiler/InterpreterProjectors.ml @@ -0,0 +1,543 @@ +module T = Types +module V = Values +module E = Expressions +module C = Contexts +module Subst = Substitute +module L = Logging +open TypesUtils +open InterpreterUtils +open InterpreterBorrowsCore + +(** Auxiliary function. + + Apply a proj_borrows on a shared borrow. + Note that when projecting over shared values, we generate + {!V.abstract_shared_borrows}, not {!V.avalue}s. +*) +let rec apply_proj_borrows_on_shared_borrow (ctx : C.eval_ctx) + (fresh_reborrow : V.BorrowId.id -> V.BorrowId.id) + (regions : T.RegionId.Set.t) (v : V.typed_value) (ty : T.rty) : + V.abstract_shared_borrows = + (* Sanity check - TODO: move this elsewhere (here we perform the check at every + * recursive call which is a bit overkill...) *) + let ety = Subst.erase_regions ty in + assert (ety = v.V.ty); + (* Project - if there are no regions from the abstraction in the type, return [_] *) + if not (ty_has_regions_in_set regions ty) then [] + else + match (v.V.value, ty) with + | V.Concrete _, (T.Bool | T.Char | T.Integer _ | T.Str) -> [] + | V.Adt adt, T.Adt (id, region_params, tys) -> + (* Retrieve the types of the fields *) + let field_types = + Subst.ctx_adt_value_get_instantiated_field_rtypes ctx adt id + region_params tys + in + (* Project over the field values *) + let fields_types = List.combine adt.V.field_values field_types in + let proj_fields = + List.map + (fun (fv, fty) -> + apply_proj_borrows_on_shared_borrow ctx fresh_reborrow regions fv + fty) + fields_types + in + List.concat proj_fields + | V.Bottom, _ -> failwith "Unreachable" + | V.Borrow bc, T.Ref (r, ref_ty, kind) -> + (* Retrieve the bid of the borrow and the asb of the projected borrowed value *) + let bid, asb = + (* Not in the set: dive *) + match (bc, kind) with + | V.MutBorrow (bid, bv), T.Mut -> + (* Apply the projection on the borrowed value *) + let asb = + apply_proj_borrows_on_shared_borrow ctx fresh_reborrow regions + bv ref_ty + in + (bid, asb) + | V.SharedBorrow (_, bid), T.Shared -> + (* Lookup the shared value *) + let ek = ek_all in + let sv = lookup_loan ek bid ctx in + let asb = + match sv with + | _, Concrete (V.SharedLoan (_, sv)) + | _, Abstract (V.ASharedLoan (_, sv, _)) -> + apply_proj_borrows_on_shared_borrow ctx fresh_reborrow + regions sv ref_ty + | _ -> failwith "Unexpected" + in + (bid, asb) + | V.InactivatedMutBorrow _, _ -> + failwith + "Can't apply a proj_borrow over an inactivated mutable borrow" + | _ -> failwith "Unreachable" + in + let asb = + (* Check if the region is in the set of projected regions (note that + * we never project over static regions) *) + if region_in_set r regions then + let bid' = fresh_reborrow bid in + V.AsbBorrow bid' :: asb + else asb + in + asb + | V.Loan _, _ -> failwith "Unreachable" + | V.Symbolic s, _ -> + (* Check that the projection doesn't contain ended regions *) + assert ( + not (projections_intersect s.V.sv_ty ctx.ended_regions ty regions)); + [ V.AsbProjReborrows (s, ty) ] + | _ -> failwith "Unreachable" + +(** Apply (and reduce) a projector over borrows to a value. + + - [regions]: the regions we project + - [v]: the value over which we project + - [ty]: the projection type (is used to map borrows to regions, or to + interpret the borrows as belonging to some regions...). Remember that + [v] doesn't contain region information. + For instance, if we have: + [v <: ty] where: + - [v = mut_borrow l ...] + - [ty = Ref (r, ...)] + then we interpret the borrow [l] as belonging to region [r] + + Also, when applying projections on shared values, we need to apply + reborrows. This is a bit annoying because, with the way we compute + the projection on borrows, we can't update the context immediately. + Instead, we remember the list of borrows we have to insert in the + context *afterwards*. + + [check_symbolic_no_ended] controls whether we check or not whether + symbolic values don't contain already ended regions. + This check is activated when applying projectors upon calling a function + (because we need to check that function arguments don't contain ⊥), + but deactivated when expanding symbolic values: + {[ + fn f<'a,'b>(x : &'a mut u32, y : &'b mut u32) -> (&'a mut u32, &'b mut u32); + + let p = f(&mut x, &mut y); // p -> @s0 + assert(x == ...); // end 'a + let z = p.1; // HERE: the symbolic expansion of @s0 contains ended regions + ]} +*) +let rec apply_proj_borrows (check_symbolic_no_ended : bool) (ctx : C.eval_ctx) + (fresh_reborrow : V.BorrowId.id -> V.BorrowId.id) + (regions : T.RegionId.Set.t) (ancestors_regions : T.RegionId.Set.t) + (v : V.typed_value) (ty : T.rty) : V.typed_avalue = + (* Sanity check - TODO: move this elsewhere (here we perform the check at every + * recursive call which is a bit overkill...) *) + let ety = Substitute.erase_regions ty in + assert (ety = v.V.ty); + (* Project - if there are no regions from the abstraction in the type, return [_] *) + if not (ty_has_regions_in_set regions ty) then { V.value = V.AIgnored; ty } + else + let value : V.avalue = + match (v.V.value, ty) with + | V.Concrete cv, (T.Bool | T.Char | T.Integer _ | T.Str) -> V.AConcrete cv + | V.Adt adt, T.Adt (id, region_params, tys) -> + (* Retrieve the types of the fields *) + let field_types = + Subst.ctx_adt_value_get_instantiated_field_rtypes ctx adt id + region_params tys + in + (* Project over the field values *) + let fields_types = List.combine adt.V.field_values field_types in + let proj_fields = + List.map + (fun (fv, fty) -> + apply_proj_borrows check_symbolic_no_ended ctx fresh_reborrow + regions ancestors_regions fv fty) + fields_types + in + V.AAdt { V.variant_id = adt.V.variant_id; field_values = proj_fields } + | V.Bottom, _ -> failwith "Unreachable" + | V.Borrow bc, T.Ref (r, ref_ty, kind) -> + if + (* Check if the region is in the set of projected regions (note that + * we never project over static regions) *) + region_in_set r regions + then + (* In the set *) + let bc = + match (bc, kind) with + | V.MutBorrow (bid, bv), T.Mut -> + (* Remember the borrowed value we are about to project as a meta-value *) + let mv = bv in + (* Apply the projection on the borrowed value *) + let bv = + apply_proj_borrows check_symbolic_no_ended ctx + fresh_reborrow regions ancestors_regions bv ref_ty + in + V.AMutBorrow (mv, bid, bv) + | V.SharedBorrow (_, bid), T.Shared -> V.ASharedBorrow bid + | V.InactivatedMutBorrow _, _ -> + failwith + "Can't apply a proj_borrow over an inactivated mutable \ + borrow" + | _ -> failwith "Unreachable" + in + V.ABorrow bc + else + (* Not in the set: ignore *) + let bc = + match (bc, kind) with + | V.MutBorrow (bid, bv), T.Mut -> + (* Apply the projection on the borrowed value *) + let bv = + apply_proj_borrows check_symbolic_no_ended ctx + fresh_reborrow regions ancestors_regions bv ref_ty + in + (* If the borrow id is in the ancestor's regions, we still need + * to remember it *) + let opt_bid = + if region_in_set r ancestors_regions then Some bid else None + in + (* Return *) + V.AIgnoredMutBorrow (opt_bid, bv) + | V.SharedBorrow (_, bid), T.Shared -> + (* Lookup the shared value *) + let ek = ek_all in + let sv = lookup_loan ek bid ctx in + let asb = + match sv with + | _, Concrete (V.SharedLoan (_, sv)) + | _, Abstract (V.ASharedLoan (_, sv, _)) -> + apply_proj_borrows_on_shared_borrow ctx fresh_reborrow + regions sv ref_ty + | _ -> failwith "Unexpected" + in + V.AProjSharedBorrow asb + | V.InactivatedMutBorrow _, _ -> + failwith + "Can't apply a proj_borrow over an inactivated mutable \ + borrow" + | _ -> failwith "Unreachable" + in + V.ABorrow bc + | V.Loan _, _ -> failwith "Unreachable" + | V.Symbolic s, _ -> + (* Check that the projection doesn't contain already ended regions, + * if necessary *) + if check_symbolic_no_ended then ( + let ty1 = s.V.sv_ty in + let rset1 = ctx.ended_regions in + let ty2 = ty in + let rset2 = regions in + log#ldebug + (lazy + ("projections_intersect:" ^ "\n- ty1: " ^ rty_to_string ctx ty1 + ^ "\n- rset1: " + ^ T.RegionId.Set.to_string None rset1 + ^ "\n- ty2: " ^ rty_to_string ctx ty2 ^ "\n- rset2: " + ^ T.RegionId.Set.to_string None rset2 + ^ "\n")); + assert (not (projections_intersect ty1 rset1 ty2 rset2))); + V.ASymbolic (V.AProjBorrows (s, ty)) + | _ -> + log#lerror + (lazy + ("apply_proj_borrows: unexpected inputs:\n- input value: " + ^ typed_value_to_string ctx v + ^ "\n- proj rty: " ^ rty_to_string ctx ty)); + failwith "Unreachable" + in + { V.value; V.ty } + +(** Convert a symbolic expansion *which is not a borrow* to a value *) +let symbolic_expansion_non_borrow_to_value (sv : V.symbolic_value) + (see : V.symbolic_expansion) : V.typed_value = + let ty = Subst.erase_regions sv.V.sv_ty in + let value = + match see with + | SeConcrete cv -> V.Concrete cv + | SeAdt (variant_id, field_values) -> + let field_values = + List.map mk_typed_value_from_symbolic_value field_values + in + V.Adt { V.variant_id; V.field_values } + | SeMutRef (_, _) | SeSharedRef (_, _) -> + failwith "Unexpected symbolic reference expansion" + in + { V.value; V.ty } + +(** Convert a symbolic expansion to a value. + + If the expansion is a mutable reference expansion, it converts it to a borrow. + This function is meant to be used when reducing projectors over borrows, + during a symbolic expansion. + *) +let symbolic_expansion_non_shared_borrow_to_value (sv : V.symbolic_value) + (see : V.symbolic_expansion) : V.typed_value = + match see with + | SeMutRef (bid, bv) -> + let ty = Subst.erase_regions sv.V.sv_ty in + let bv = mk_typed_value_from_symbolic_value bv in + let value = V.Borrow (V.MutBorrow (bid, bv)) in + { V.value; ty } + | SeSharedRef (_, _) -> + failwith "Unexpected symbolic shared reference expansion" + | _ -> symbolic_expansion_non_borrow_to_value sv see + +(** Apply (and reduce) a projector over loans to a value. + + TODO: detailed comments. See [apply_proj_borrows] +*) +let apply_proj_loans_on_symbolic_expansion (regions : T.RegionId.Set.t) + (see : V.symbolic_expansion) (original_sv_ty : T.rty) : V.typed_avalue = + (* Sanity check: if we have a proj_loans over a symbolic value, it should + * contain regions which we will project *) + assert (ty_has_regions_in_set regions original_sv_ty); + (* Match *) + let (value, ty) : V.avalue * T.rty = + match (see, original_sv_ty) with + | SeConcrete _, (T.Bool | T.Char | T.Integer _ | T.Str) -> + (V.AIgnored, original_sv_ty) + | SeAdt (variant_id, field_values), T.Adt (_id, _region_params, _tys) -> + (* Project over the field values *) + let field_values = + List.map + (mk_aproj_loans_value_from_symbolic_value regions) + field_values + in + (V.AAdt { V.variant_id; field_values }, original_sv_ty) + | SeMutRef (bid, spc), T.Ref (r, ref_ty, T.Mut) -> + (* Sanity check *) + assert (spc.V.sv_ty = ref_ty); + (* Apply the projector to the borrowed value *) + let child_av = mk_aproj_loans_value_from_symbolic_value regions spc in + (* Check if the region is in the set of projected regions (note that + * we never project over static regions) *) + if region_in_set r regions then + (* In the set: keep *) + (V.ALoan (V.AMutLoan (bid, child_av)), ref_ty) + else + (* Not in the set: ignore *) + (V.ALoan (V.AIgnoredMutLoan (bid, child_av)), ref_ty) + | SeSharedRef (bids, spc), T.Ref (r, ref_ty, T.Shared) -> + (* Sanity check *) + assert (spc.V.sv_ty = ref_ty); + (* Apply the projector to the borrowed value *) + let child_av = mk_aproj_loans_value_from_symbolic_value regions spc in + (* Check if the region is in the set of projected regions (note that + * we never project over static regions) *) + if region_in_set r regions then + (* In the set: keep *) + let shared_value = mk_typed_value_from_symbolic_value spc in + (V.ALoan (V.ASharedLoan (bids, shared_value, child_av)), ref_ty) + else + (* Not in the set: ignore *) + (V.ALoan (V.AIgnoredSharedLoan child_av), ref_ty) + | _ -> failwith "Unreachable" + in + { V.value; V.ty } + +(** Auxiliary function. See [give_back_value]. + + Apply reborrows to a context. + + The [reborrows] input is a list of pairs (shared loan id, id to insert + in the shared loan). + This function is used when applying projectors on shared borrows: when + doing so, we might need to reborrow subvalues from the shared value. + For instance: + {[ + fn f<'a,'b,'c>(x : &'a 'b 'c u32) + ]} + When introducing the abstractions for 'a, 'b and 'c, we apply a projector + on some value [shared_borrow l : &'a &'b &'c u32]. + In the 'a abstraction, this shared borrow gets projected. However, when + reducing the projectors for the 'b and 'c abstractions, we need to make + sure that the borrows living in regions 'b and 'c live as long as those + regions. This is done by looking up the shared value and applying reborrows + on the borrows we find there (note that those reborrows apply on shared + borrows - easy - and mutable borrows - in this case, we reborrow the whole + borrow: [mut_borrow ... ~~> shared_loan {...} (mut_borrow ...)]). +*) +let apply_reborrows (reborrows : (V.BorrowId.id * V.BorrowId.id) list) + (ctx : C.eval_ctx) : C.eval_ctx = + (* This is a bit brutal, but whenever we insert a reborrow, we remove + * it from the list. This allows us to check that all the reborrows were + * applied before returning. + * We might reimplement that in a more efficient manner by using maps. *) + let reborrows = ref reborrows in + + (* Check if a value is a mutable borrow, and return its identifier if + it is the case *) + let get_borrow_in_mut_borrow (v : V.typed_value) : V.BorrowId.id option = + match v.V.value with + | V.Borrow lc -> ( + match lc with + | V.SharedBorrow (_, _) | V.InactivatedMutBorrow _ -> None + | V.MutBorrow (id, _) -> Some id) + | _ -> None + in + + (* Add the proper reborrows to a set of borrow ids (for a shared loan) *) + let insert_reborrows bids = + (* Find the reborrows to apply *) + let insert, reborrows' = + List.partition (fun (bid, _) -> V.BorrowId.Set.mem bid bids) !reborrows + in + reborrows := reborrows'; + let insert = List.map snd insert in + (* Insert the borrows *) + List.fold_left (fun bids bid -> V.BorrowId.Set.add bid bids) bids insert + in + + (* Get the list of reborrows for a given borrow id *) + let get_reborrows_for_bid bid = + (* Find the reborrows to apply *) + let insert, reborrows' = + List.partition (fun (bid', _) -> bid' = bid) !reborrows + in + reborrows := reborrows'; + List.map snd insert + in + + let borrows_to_set bids = + List.fold_left + (fun bids bid -> V.BorrowId.Set.add bid bids) + V.BorrowId.Set.empty bids + in + + (* Insert reborrows for a given borrow id into a given set of borrows *) + let insert_reborrows_for_bid bids bid = + (* Find the reborrows to apply *) + let insert = get_reborrows_for_bid bid in + (* Insert the borrows *) + List.fold_left (fun bids bid -> V.BorrowId.Set.add bid bids) bids insert + in + + let obj = + object + inherit [_] C.map_eval_ctx as super + + (** We may need to reborrow mutable borrows. Note that this doesn't + happen for aborrows *) + method! visit_typed_value env v = + match v.V.value with + | V.Borrow (V.MutBorrow (bid, bv)) -> + let insert = get_reborrows_for_bid bid in + let nbc = super#visit_MutBorrow env bid bv in + let nbc = { v with V.value = V.Borrow nbc } in + if insert = [] then (* No reborrows: do nothing special *) + nbc + else + (* There are reborrows: insert a shared loan *) + let insert = borrows_to_set insert in + let value = V.Loan (V.SharedLoan (insert, nbc)) in + let ty = v.V.ty in + { V.value; ty } + | _ -> super#visit_typed_value env v + + (** We reimplement {!visit_loan_content} (rather than one of the sub- + functions) on purpose: exhaustive matches are good for maintenance *) + method! visit_loan_content env lc = + match lc with + | V.SharedLoan (bids, sv) -> + (* Insert the reborrows *) + let bids = insert_reborrows bids in + (* Check if the contained value is a mutable borrow, in which + * case we might need to reborrow it by adding more borrow ids + * to the current set of borrows - by doing this small + * manipulation here, we accumulate the borrow ids in the same + * shared loan, right above the mutable borrow, and avoid + * stacking shared loans (note that doing this is not a problem + * from a soundness point of view, but it is a bit ugly...) *) + let bids = + match get_borrow_in_mut_borrow sv with + | None -> bids + | Some bid -> insert_reborrows_for_bid bids bid + in + (* Update and explore *) + super#visit_SharedLoan env bids sv + | V.MutLoan bid -> + (* Nothing special to do *) + super#visit_MutLoan env bid + + method! visit_aloan_content env lc = + match lc with + | V.ASharedLoan (bids, sv, av) -> + (* Insert the reborrows *) + let bids = insert_reborrows bids in + (* Similarly to the non-abstraction case: check if the shared + * value is a mutable borrow, to eventually insert more reborrows *) + (* Update and explore *) + let bids = + match get_borrow_in_mut_borrow sv with + | None -> bids + | Some bid -> insert_reborrows_for_bid bids bid + in + (* Update and explore *) + super#visit_ASharedLoan env bids sv av + | V.AIgnoredSharedLoan _ + | V.AMutLoan (_, _) + | V.AEndedMutLoan { given_back = _; child = _; given_back_meta = _ } + | V.AEndedSharedLoan (_, _) + | V.AIgnoredMutLoan (_, _) + | V.AEndedIgnoredMutLoan + { given_back = _; child = _; given_back_meta = _ } -> + (* Nothing particular to do *) + super#visit_aloan_content env lc + end + in + + (* Visit *) + let ctx = obj#visit_eval_ctx () ctx in + (* Check that there are no reborrows remaining *) + assert (!reborrows = []); + (* Return *) + ctx + +(** Auxiliary function to prepare reborrowing operations (used when + applying projectors). + + Returns two functions: + - a function to generate fresh re-borrow ids, and register the reborrows + - a function to apply the reborrows in a context + Those functions are of course stateful. + *) +let prepare_reborrows (config : C.config) (allow_reborrows : bool) : + (V.BorrowId.id -> V.BorrowId.id) * (C.eval_ctx -> C.eval_ctx) = + let reborrows : (V.BorrowId.id * V.BorrowId.id) list ref = ref [] in + (* The function to generate and register fresh reborrows *) + let fresh_reborrow (bid : V.BorrowId.id) : V.BorrowId.id = + if allow_reborrows then ( + let bid' = C.fresh_borrow_id () in + reborrows := (bid, bid') :: !reborrows; + bid') + else failwith "Unexpected reborrow" + in + (* The function to apply the reborrows in a context *) + let apply_registered_reborrows (ctx : C.eval_ctx) : C.eval_ctx = + match config.C.mode with + | C.ConcreteMode -> + assert (!reborrows = []); + ctx + | C.SymbolicMode -> + (* Apply the reborrows *) + apply_reborrows !reborrows ctx + in + (fresh_reborrow, apply_registered_reborrows) + +let apply_proj_borrows_on_input_value (config : C.config) (ctx : C.eval_ctx) + (regions : T.RegionId.Set.t) (ancestors_regions : T.RegionId.Set.t) + (v : V.typed_value) (ty : T.rty) : C.eval_ctx * V.typed_avalue = + let check_symbolic_no_ended = true in + let allow_reborrows = true in + (* Prepare the reborrows *) + let fresh_reborrow, apply_registered_reborrows = + prepare_reborrows config allow_reborrows + in + (* Apply the projector *) + let av = + apply_proj_borrows check_symbolic_no_ended ctx fresh_reborrow regions + ancestors_regions v ty + in + (* Apply the reborrows *) + let ctx = apply_registered_reborrows ctx in + (* Return *) + (ctx, av) diff --git a/compiler/InterpreterStatements.ml b/compiler/InterpreterStatements.ml new file mode 100644 index 00000000..4e61e683 --- /dev/null +++ b/compiler/InterpreterStatements.ml @@ -0,0 +1,1370 @@ +module T = Types +module V = Values +module E = Expressions +module C = Contexts +module Subst = Substitute +module A = LlbcAst +module L = Logging +open TypesUtils +open ValuesUtils +module Inv = Invariants +module S = SynthesizeSymbolic +open Errors +open Cps +open InterpreterUtils +open InterpreterProjectors +open InterpreterExpansion +open InterpreterPaths +open InterpreterExpressions + +(** The local logger *) +let log = L.statements_log + +(** Drop a value at a given place - TODO: factorize this with [assign_to_place] *) +let drop_value (config : C.config) (p : E.place) : cm_fun = + fun cf ctx -> + log#ldebug + (lazy + ("drop_value: place: " ^ place_to_string ctx p ^ "\n- Initial context:\n" + ^ eval_ctx_to_string ctx)); + (* Prepare the place (by ending the outer loans). + * Note that {!prepare_lplace} will use the [Write] access kind: + * it is ok, because when updating the value with {!Bottom} below, + * we will use the [Move] access *) + let end_borrows = false in + let prepare = prepare_lplace config end_borrows p in + (* Replace the value with {!Bottom} *) + let replace cf (v : V.typed_value) ctx = + (* Move the value at destination (that we will overwrite) to a dummy variable + * to preserve the borrows *) + let mv = read_place_unwrap config Write p ctx in + let ctx = C.ctx_push_dummy_var ctx mv in + (* Update the destination to ⊥ *) + let nv = { v with value = V.Bottom } in + let ctx = write_place_unwrap config Move p nv ctx in + log#ldebug + (lazy + ("drop_value: place: " ^ place_to_string ctx p ^ "\n- Final context:\n" + ^ eval_ctx_to_string ctx)); + cf ctx + in + (* Compose and apply *) + comp prepare replace cf ctx + +(** Push a dummy variable to the environment *) +let push_dummy_var (v : V.typed_value) : cm_fun = + fun cf ctx -> + let ctx = C.ctx_push_dummy_var ctx v in + cf ctx + +(** Pop a dummy variable from the environment *) +let pop_dummy_var (cf : V.typed_value -> m_fun) : m_fun = + fun ctx -> + let ctx, v = C.ctx_pop_dummy_var ctx in + cf v ctx + +(** Push an uninitialized variable to the environment *) +let push_uninitialized_var (var : A.var) : cm_fun = + fun cf ctx -> + let ctx = C.ctx_push_uninitialized_var ctx var in + cf ctx + +(** Push a list of uninitialized variables to the environment *) +let push_uninitialized_vars (vars : A.var list) : cm_fun = + fun cf ctx -> + let ctx = C.ctx_push_uninitialized_vars ctx vars in + cf ctx + +(** Push a variable to the environment *) +let push_var (var : A.var) (v : V.typed_value) : cm_fun = + fun cf ctx -> + let ctx = C.ctx_push_var ctx var v in + cf ctx + +(** Push a list of variables to the environment *) +let push_vars (vars : (A.var * V.typed_value) list) : cm_fun = + fun cf ctx -> + let ctx = C.ctx_push_vars ctx vars in + cf ctx + +(** Assign a value to a given place. + + Note that this function first pushes the value to assign in a dummy variable, + then prepares the destination (by ending borrows, etc.) before popping the + dummy variable and putting in its destination (after having checked that + preparing the destination didn't introduce ⊥). + *) +let assign_to_place (config : C.config) (rv : V.typed_value) (p : E.place) : + cm_fun = + fun cf ctx -> + log#ldebug + (lazy + ("assign_to_place:" ^ "\n- rv: " + ^ typed_value_to_string ctx rv + ^ "\n- p: " ^ place_to_string ctx p ^ "\n- Initial context:\n" + ^ eval_ctx_to_string ctx)); + (* Push the rvalue to a dummy variable, for bookkeeping *) + let cc = push_dummy_var rv in + (* Prepare the destination *) + let end_borrows = false in + let cc = comp cc (prepare_lplace config end_borrows p) in + (* Retrieve the rvalue from the dummy variable *) + let cc = comp cc (fun cf _lv -> pop_dummy_var cf) in + (* Update the destination *) + let move_dest cf (rv : V.typed_value) : m_fun = + fun ctx -> + (* Move the value at destination (that we will overwrite) to a dummy variable + * to preserve the borrows *) + let mv = read_place_unwrap config Write p ctx in + let ctx = C.ctx_push_dummy_var ctx mv in + (* Write to the destination *) + (* Checks - maybe the bookkeeping updated the rvalue and introduced bottoms *) + assert (not (bottom_in_value ctx.ended_regions rv)); + (* Update the destination *) + let ctx = write_place_unwrap config Write p rv ctx in + (* Debug *) + log#ldebug + (lazy + ("assign_to_place:" ^ "\n- rv: " + ^ typed_value_to_string ctx rv + ^ "\n- p: " ^ place_to_string ctx p ^ "\n- Final context:\n" + ^ eval_ctx_to_string ctx)); + (* Continue *) + cf ctx + in + (* Compose and apply *) + comp cc move_dest cf ctx + +(** Evaluate an assertion, when the scrutinee is not symbolic *) +let eval_assertion_concrete (config : C.config) (assertion : A.assertion) : + st_cm_fun = + fun cf ctx -> + (* There won't be any symbolic expansions: fully evaluate the operand *) + let eval_op = eval_operand config assertion.cond in + let eval_assert cf (v : V.typed_value) : m_fun = + fun ctx -> + match v.value with + | Concrete (Bool b) -> + (* Branch *) + if b = assertion.expected then cf Unit ctx else cf Panic ctx + | _ -> + raise + (Failure ("Expected a boolean, got: " ^ typed_value_to_string ctx v)) + in + (* Compose and apply *) + comp eval_op eval_assert cf ctx + +(** Evaluates an assertion. + + In the case the boolean under scrutinee is symbolic, we synthesize + a call to [assert ...] then continue in the success branch (and thus + expand the boolean to [true]). + *) +let eval_assertion (config : C.config) (assertion : A.assertion) : st_cm_fun = + fun cf ctx -> + (* Evaluate the operand *) + let eval_op = eval_operand config assertion.cond in + (* Evaluate the assertion *) + let eval_assert cf (v : V.typed_value) : m_fun = + fun ctx -> + assert (v.ty = T.Bool); + (* We make a choice here: we could completely decouple the concrete and + * symbolic executions here but choose not to. In the case where we + * know the concrete value of the boolean we test, we use this value + * even if we are in symbolic mode. Note that this case should be + * extremely rare... *) + match v.value with + | Concrete (Bool _) -> + (* Delegate to the concrete evaluation function *) + eval_assertion_concrete config assertion cf ctx + | Symbolic sv -> + assert (config.mode = C.SymbolicMode); + assert (sv.V.sv_ty = T.Bool); + (* Expand the symbolic value and call the proper continuation functions + * for the true and false cases - TODO: call an "assert" function instead *) + let cf_true : m_fun = fun ctx -> cf Unit ctx in + let cf_false : m_fun = fun ctx -> cf Panic ctx in + let expand = + expand_symbolic_bool config sv + (S.mk_opt_place_from_op assertion.cond ctx) + cf_true cf_false + in + expand ctx + | _ -> + raise + (Failure ("Expected a boolean, got: " ^ typed_value_to_string ctx v)) + in + (* Compose and apply *) + comp eval_op eval_assert cf ctx + +(** Updates the discriminant of a value at a given place. + + There are two situations: + - either the discriminant is already the proper one (in which case we + don't do anything) + - or it is not the proper one (because the variant is not the proper + one, or the value is actually {!V.Bottom} - this happens when + initializing ADT values), in which case we replace the value with + a variant with all its fields set to {!V.Bottom}. + For instance, something like: [Cons Bottom Bottom]. + *) +let set_discriminant (config : C.config) (p : E.place) + (variant_id : T.VariantId.id) : st_cm_fun = + fun cf ctx -> + log#ldebug + (lazy + ("set_discriminant:" ^ "\n- p: " ^ place_to_string ctx p + ^ "\n- variant id: " + ^ T.VariantId.to_string variant_id + ^ "\n- initial context:\n" ^ eval_ctx_to_string ctx)); + (* Access the value *) + let access = Write in + let cc = update_ctx_along_read_place config access p in + let end_borrows = false in + let cc = comp cc (prepare_lplace config end_borrows p) in + (* Update the value *) + let update_value cf (v : V.typed_value) : m_fun = + fun ctx -> + match (v.V.ty, v.V.value) with + | ( T.Adt (((T.AdtId _ | T.Assumed T.Option) as type_id), regions, types), + V.Adt av ) -> ( + (* There are two situations: + - either the discriminant is already the proper one (in which case we + don't do anything) + - or it is not the proper one, in which case we replace the value with + a variant with all its fields set to {!Bottom} + *) + match av.variant_id with + | None -> raise (Failure "Found a struct value while expected an enum") + | Some variant_id' -> + if variant_id' = variant_id then (* Nothing to do *) + cf Unit ctx + else + (* Replace the value *) + let bottom_v = + match type_id with + | T.AdtId def_id -> + compute_expanded_bottom_adt_value + ctx.type_context.type_decls def_id (Some variant_id) + regions types + | T.Assumed T.Option -> + assert (regions = []); + compute_expanded_bottom_option_value variant_id + (Collections.List.to_cons_nil types) + | _ -> raise (Failure "Unreachable") + in + assign_to_place config bottom_v p (cf Unit) ctx) + | ( T.Adt (((T.AdtId _ | T.Assumed T.Option) as type_id), regions, types), + V.Bottom ) -> + let bottom_v = + match type_id with + | T.AdtId def_id -> + compute_expanded_bottom_adt_value ctx.type_context.type_decls + def_id (Some variant_id) regions types + | T.Assumed T.Option -> + assert (regions = []); + compute_expanded_bottom_option_value variant_id + (Collections.List.to_cons_nil types) + | _ -> raise (Failure "Unreachable") + in + assign_to_place config bottom_v p (cf Unit) ctx + | _, V.Symbolic _ -> + assert (config.mode = SymbolicMode); + (* This is a bit annoying: in theory we should expand the symbolic value + * then set the discriminant, because in the case the discriminant is + * exactly the one we set, the fields are left untouched, and in the + * other cases they are set to Bottom. + * For now, we forbid setting the discriminant of a symbolic value: + * setting a discriminant should only be used to initialize a value, + * or reset an already initialized value, really. *) + raise (Failure "Unexpected value") + | _, (V.Adt _ | V.Bottom) -> raise (Failure "Inconsistent state") + | _, (V.Concrete _ | V.Borrow _ | V.Loan _) -> + raise (Failure "Unexpected value") + in + (* Compose and apply *) + comp cc update_value cf ctx + +(** Push a frame delimiter in the context's environment *) +let ctx_push_frame (ctx : C.eval_ctx) : C.eval_ctx = + { ctx with env = Frame :: ctx.env } + +(** Push a frame delimiter in the context's environment *) +let push_frame : cm_fun = fun cf ctx -> cf (ctx_push_frame ctx) + +(** Small helper: compute the type of the return value for a specific + instantiation of a non-local function. + *) +let get_non_local_function_return_type (fid : A.assumed_fun_id) + (region_params : T.erased_region list) (type_params : T.ety list) : T.ety = + (* [Box::free] has a special treatment *) + match (fid, region_params, type_params) with + | A.BoxFree, [], [ _ ] -> mk_unit_ty + | _ -> + (* Retrieve the function's signature *) + let sg = Assumed.get_assumed_sig fid in + (* Instantiate the return type *) + let tsubst = + Subst.make_type_subst + (List.map (fun v -> v.T.index) sg.type_params) + type_params + in + Subst.erase_regions_substitute_types tsubst sg.output + +let move_return_value (config : C.config) (cf : V.typed_value -> m_fun) : m_fun + = + fun ctx -> + let ret_vid = V.VarId.zero in + let cc = eval_operand config (E.Move (mk_place_from_var_id ret_vid)) in + cc cf ctx + +(** Pop the current frame. + + Drop all the local variables but the return variable, move the return + value out of the return variable, remove all the local variables (but not the + abstractions!) from the context, remove the {!C.Frame} indicator delimiting the + current frame and handle the return value to the continuation. + + TODO: rename (remove the "ctx_") + *) +let ctx_pop_frame (config : C.config) (cf : V.typed_value -> m_fun) : m_fun = + fun ctx -> + (* Debug *) + log#ldebug (lazy ("ctx_pop_frame:\n" ^ eval_ctx_to_string ctx)); + + (* List the local variables, but the return variable *) + let ret_vid = V.VarId.zero in + let rec list_locals env = + match env with + | [] -> raise (Failure "Inconsistent environment") + | C.Abs _ :: env -> list_locals env + | C.Var (None, _) :: env -> list_locals env + | C.Var (Some var, _) :: env -> + let locals = list_locals env in + if var.index <> ret_vid then var.index :: locals else locals + | C.Frame :: _ -> [] + in + let locals : V.VarId.id list = list_locals ctx.env in + (* Debug *) + log#ldebug + (lazy + ("ctx_pop_frame: locals in which to drop the outer loans: [" + ^ String.concat "," (List.map V.VarId.to_string locals) + ^ "]")); + + (* Move the return value out of the return variable *) + let cc = move_return_value config in + (* Sanity check *) + let cc = + comp_check_value cc (fun ret_value ctx -> + assert (not (bottom_in_value ctx.ended_regions ret_value))) + in + + (* Drop the outer *loans* we find in the local variables *) + let cf_drop_loans_in_locals cf (ret_value : V.typed_value) : m_fun = + (* Drop the loans *) + let end_borrows = false in + let locals = List.rev locals in + let cf_drop = + List.fold_left + (fun cf lid -> + drop_outer_borrows_loans_at_lplace config end_borrows + (mk_place_from_var_id lid) cf) + (cf ret_value) locals + in + (* Apply *) + cf_drop + in + let cc = comp cc cf_drop_loans_in_locals in + (* Debug *) + let cc = + comp_check_value cc (fun _ ctx -> + log#ldebug + (lazy + ("ctx_pop_frame: after dropping outer loans in local variables:\n" + ^ eval_ctx_to_string ctx))) + in + + (* Pop the frame - we remove the [Frame] delimiter, and reintroduce all + * the local variables (which may still contain borrow permissions - but + * no outer loans) as dummy variables in the caller frame *) + let rec pop env = + match env with + | [] -> raise (Failure "Inconsistent environment") + | C.Abs abs :: env -> C.Abs abs :: pop env + | C.Var (_, v) :: env -> C.Var (None, v) :: pop env + | C.Frame :: env -> (* Stop here *) env + in + let cf_pop cf (ret_value : V.typed_value) : m_fun = + fun ctx -> + let env = pop ctx.env in + let ctx = { ctx with env } in + cf ret_value ctx + in + (* Compose and apply *) + comp cc cf_pop cf ctx + +(** Pop the current frame and assign the returned value to its destination. *) +let pop_frame_assign (config : C.config) (dest : E.place) : cm_fun = + let cf_pop = ctx_pop_frame config in + let cf_assign cf ret_value : m_fun = + assign_to_place config ret_value dest cf + in + comp cf_pop cf_assign + +(** Auxiliary function - see [eval_non_local_function_call] *) +let eval_replace_concrete (_config : C.config) + (_region_params : T.erased_region list) (_type_params : T.ety list) : cm_fun + = + fun _cf _ctx -> raise Unimplemented + +(** Auxiliary function - see [eval_non_local_function_call] *) +let eval_box_new_concrete (config : C.config) + (region_params : T.erased_region list) (type_params : T.ety list) : cm_fun = + fun cf ctx -> + (* Check and retrieve the arguments *) + match (region_params, type_params, ctx.env) with + | ( [], + [ boxed_ty ], + Var (Some input_var, input_value) :: Var (_ret_var, _) :: C.Frame :: _ ) + -> + (* Required type checking *) + assert (input_value.V.ty = boxed_ty); + + (* Move the input value *) + let cf_move = + eval_operand config (E.Move (mk_place_from_var_id input_var.C.index)) + in + + (* Create the new box *) + let cf_create cf (moved_input_value : V.typed_value) : m_fun = + (* Create the box value *) + let box_ty = T.Adt (T.Assumed T.Box, [], [ boxed_ty ]) in + let box_v = + V.Adt { variant_id = None; field_values = [ moved_input_value ] } + in + let box_v = mk_typed_value box_ty box_v in + + (* Move this value to the return variable *) + let dest = mk_place_from_var_id V.VarId.zero in + let cf_assign = assign_to_place config box_v dest in + + (* Continue *) + cf_assign cf + in + + (* Compose and apply *) + comp cf_move cf_create cf ctx + | _ -> raise (Failure "Inconsistent state") + +(** Auxiliary function which factorizes code to evaluate [std::Deref::deref] + and [std::DerefMut::deref_mut] - see [eval_non_local_function_call] *) +let eval_box_deref_mut_or_shared_concrete (config : C.config) + (region_params : T.erased_region list) (type_params : T.ety list) + (is_mut : bool) : cm_fun = + fun cf ctx -> + (* Check the arguments *) + match (region_params, type_params, ctx.env) with + | ( [], + [ boxed_ty ], + Var (Some input_var, input_value) :: Var (_ret_var, _) :: C.Frame :: _ ) + -> + (* Required type checking. We must have: + - input_value.ty == & (mut) Box<ty> + - boxed_ty == ty + for some ty + *) + (let _, input_ty, ref_kind = ty_get_ref input_value.V.ty in + assert (match ref_kind with T.Shared -> not is_mut | T.Mut -> is_mut); + let input_ty = ty_get_box input_ty in + assert (input_ty = boxed_ty)); + + (* Borrow the boxed value *) + let p = + { E.var_id = input_var.C.index; projection = [ E.Deref; E.DerefBox ] } + in + let borrow_kind = if is_mut then E.Mut else E.Shared in + let rv = E.Ref (p, borrow_kind) in + let cf_borrow = eval_rvalue config rv in + + (* Move the borrow to its destination *) + let cf_move cf res : m_fun = + match res with + | Error EPanic -> + (* We can't get there by borrowing a value *) + raise (Failure "Unreachable") + | Ok borrowed_value -> + (* Move and continue *) + let destp = mk_place_from_var_id V.VarId.zero in + assign_to_place config borrowed_value destp cf + in + + (* Compose and apply *) + comp cf_borrow cf_move cf ctx + | _ -> raise (Failure "Inconsistent state") + +(** Auxiliary function - see [eval_non_local_function_call] *) +let eval_box_deref_concrete (config : C.config) + (region_params : T.erased_region list) (type_params : T.ety list) : cm_fun = + let is_mut = false in + eval_box_deref_mut_or_shared_concrete config region_params type_params is_mut + +(** Auxiliary function - see [eval_non_local_function_call] *) +let eval_box_deref_mut_concrete (config : C.config) + (region_params : T.erased_region list) (type_params : T.ety list) : cm_fun = + let is_mut = true in + eval_box_deref_mut_or_shared_concrete config region_params type_params is_mut + +(** Auxiliary function - see [eval_non_local_function_call]. + + [Box::free] is not handled the same way as the other assumed functions: + - in the regular case, whenever we need to evaluate an assumed function, + we evaluate the operands, push a frame, call a dedicated function + to correctly update the variables in the frame (and mimic the execution + of a body) and finally pop the frame + - in the case of [Box::free]: the value given to this function is often + of the form [Box(⊥)] because we can move the value out of the + box before freeing the box. It makes it invalid to see box_free as a + "regular" function: it is not valid to call a function with arguments + which contain [⊥]. For this reason, we execute [Box::free] as drop_value, + but this is a bit annoying with regards to the semantics... + + Followingly this function doesn't behave like the others: it does not expect + a stack frame to have been pushed, but rather simply behaves like {!drop_value}. + It thus updates the box value (by calling {!drop_value}) and updates + the destination (by setting it to [()]). +*) +let eval_box_free (config : C.config) (region_params : T.erased_region list) + (type_params : T.ety list) (args : E.operand list) (dest : E.place) : cm_fun + = + fun cf ctx -> + match (region_params, type_params, args) with + | [], [ boxed_ty ], [ E.Move input_box_place ] -> + (* Required type checking *) + let input_box = read_place_unwrap config Write input_box_place ctx in + (let input_ty = ty_get_box input_box.V.ty in + assert (input_ty = boxed_ty)); + + (* Drop the value *) + let cc = drop_value config input_box_place in + + (* Update the destination by setting it to [()] *) + let cc = comp cc (assign_to_place config mk_unit_value dest) in + + (* Continue *) + cc cf ctx + | _ -> raise (Failure "Inconsistent state") + +(** Auxiliary function - see [eval_non_local_function_call] *) +let eval_vec_function_concrete (_config : C.config) (_fid : A.assumed_fun_id) + (_region_params : T.erased_region list) (_type_params : T.ety list) : cm_fun + = + fun _cf _ctx -> raise Unimplemented + +(** Evaluate a non-local function call in concrete mode *) +let eval_non_local_function_call_concrete (config : C.config) + (fid : A.assumed_fun_id) (region_params : T.erased_region list) + (type_params : T.ety list) (args : E.operand list) (dest : E.place) : cm_fun + = + (* There are two cases (and this is extremely annoying): + - the function is not box_free + - the function is box_free + See {!eval_box_free} + *) + match fid with + | A.BoxFree -> + (* Degenerate case: box_free *) + eval_box_free config region_params type_params args dest + | _ -> + (* "Normal" case: not box_free *) + (* Evaluate the operands *) + (* let ctx, args_vl = eval_operands config ctx args in *) + let cf_eval_ops = eval_operands config args in + + (* Evaluate the call + * + * Style note: at some point we used {!comp_transmit} to + * transmit the result of {!eval_operands} above down to {!push_vars} + * below, without having to introduce an intermediary function call, + * but it made it less clear where the computed values came from, + * so we reversed the modifications. *) + let cf_eval_call cf (args_vl : V.typed_value list) : m_fun = + (* Push the stack frame: we initialize the frame with the return variable, + and one variable per input argument *) + let cc = push_frame in + + (* Create and push the return variable *) + let ret_vid = V.VarId.zero in + let ret_ty = + get_non_local_function_return_type fid region_params type_params + in + let ret_var = mk_var ret_vid (Some "@return") ret_ty in + let cc = comp cc (push_uninitialized_var ret_var) in + + (* Create and push the input variables *) + let input_vars = + V.VarId.mapi_from1 + (fun id (v : V.typed_value) -> (mk_var id None v.V.ty, v)) + args_vl + in + let cc = comp cc (push_vars input_vars) in + + (* "Execute" the function body. As the functions are assumed, here we call + * custom functions to perform the proper manipulations: we don't have + * access to a body. *) + let cf_eval_body : cm_fun = + match fid with + | A.Replace -> eval_replace_concrete config region_params type_params + | BoxNew -> eval_box_new_concrete config region_params type_params + | BoxDeref -> eval_box_deref_concrete config region_params type_params + | BoxDerefMut -> + eval_box_deref_mut_concrete config region_params type_params + | BoxFree -> + (* Should have been treated above *) raise (Failure "Unreachable") + | VecNew | VecPush | VecInsert | VecLen | VecIndex | VecIndexMut -> + eval_vec_function_concrete config fid region_params type_params + in + + let cc = comp cc cf_eval_body in + + (* Pop the frame *) + let cc = comp cc (pop_frame_assign config dest) in + + (* Continue *) + cc cf + in + (* Compose and apply *) + comp cf_eval_ops cf_eval_call + +(** Instantiate a function signature, introducing fresh abstraction ids and + region ids. This is mostly used in preparation of function calls, when + evaluating in symbolic mode of course. + + Note: there are no region parameters, because they should be erased. + + **Rk.:** this function is **stateful** and generates fresh abstraction ids + for the region groups. + *) +let instantiate_fun_sig (type_params : T.ety list) (sg : A.fun_sig) : + A.inst_fun_sig = + (* Generate fresh abstraction ids and create a substitution from region + * group ids to abstraction ids *) + let rg_abs_ids_bindings = + List.map + (fun rg -> + let abs_id = C.fresh_abstraction_id () in + (rg.T.id, abs_id)) + sg.regions_hierarchy + in + let asubst_map : V.AbstractionId.id T.RegionGroupId.Map.t = + List.fold_left + (fun mp (rg_id, abs_id) -> T.RegionGroupId.Map.add rg_id abs_id mp) + T.RegionGroupId.Map.empty rg_abs_ids_bindings + in + let asubst (rg_id : T.RegionGroupId.id) : V.AbstractionId.id = + T.RegionGroupId.Map.find rg_id asubst_map + in + (* Generate fresh regions and their substitutions *) + let _, rsubst, _ = Subst.fresh_regions_with_substs sg.region_params in + (* Generate the type substitution + * Note that we need the substitution to map the type variables to + * {!rty} types (not {!ety}). In order to do that, we convert the + * type parameters to types with regions. This is possible only + * if those types don't contain any regions. + * This is a current limitation of the analysis: there is still some + * work to do to properly handle full type parametrization. + * *) + let rtype_params = List.map ety_no_regions_to_rty type_params in + let tsubst = + Subst.make_type_subst + (List.map (fun v -> v.T.index) sg.type_params) + rtype_params + in + (* Substitute the signature *) + let inst_sig = Subst.substitute_signature asubst rsubst tsubst sg in + (* Return *) + inst_sig + +(** Helper + + Create abstractions (with no avalues, which have to be inserted afterwards) + from a list of abs region groups. + + [region_can_end]: gives the region groups from which we generate functions + which can end or not. + *) +let create_empty_abstractions_from_abs_region_groups (call_id : V.FunCallId.id) + (kind : V.abs_kind) (rgl : A.abs_region_group list) + (region_can_end : T.RegionGroupId.id -> bool) : V.abs list = + (* We use a reference to progressively create a map from abstraction ids + * to set of ancestor regions. Note that {!abs_to_ancestors_regions} [abs_id] + * returns the union of: + * - the regions of the ancestors of abs_id + * - the regions of abs_id + *) + let abs_to_ancestors_regions : T.RegionId.Set.t V.AbstractionId.Map.t ref = + ref V.AbstractionId.Map.empty + in + (* Auxiliary function to create one abstraction *) + let create_abs (back_id : T.RegionGroupId.id) (rg : A.abs_region_group) : + V.abs = + let abs_id = rg.T.id in + let original_parents = rg.parents in + let parents = + List.fold_left + (fun s pid -> V.AbstractionId.Set.add pid s) + V.AbstractionId.Set.empty rg.parents + in + let regions = + List.fold_left + (fun s rid -> T.RegionId.Set.add rid s) + T.RegionId.Set.empty rg.regions + in + let ancestors_regions = + List.fold_left + (fun acc parent_id -> + T.RegionId.Set.union acc + (V.AbstractionId.Map.find parent_id !abs_to_ancestors_regions)) + T.RegionId.Set.empty rg.parents + in + let ancestors_regions_union_current_regions = + T.RegionId.Set.union ancestors_regions regions + in + let can_end = region_can_end back_id in + abs_to_ancestors_regions := + V.AbstractionId.Map.add abs_id ancestors_regions_union_current_regions + !abs_to_ancestors_regions; + (* Create the abstraction *) + { + V.abs_id; + call_id; + back_id; + kind; + can_end; + parents; + original_parents; + regions; + ancestors_regions; + avalues = []; + } + in + (* Apply *) + T.RegionGroupId.mapi create_abs rgl + +(** Helper. + + Create a list of abstractions from a list of regions groups, and insert + them in the context. + + [region_can_end]: gives the region groups from which we generate functions + which can end or not. + + [compute_abs_avalues]: this function must compute, given an initialized, + empty (i.e., with no avalues) abstraction, compute the avalues which + should be inserted in this abstraction before we insert it in the context. + Note that this function may update the context: it is necessary when + computing borrow projections, for instance. +*) +let create_push_abstractions_from_abs_region_groups (call_id : V.FunCallId.id) + (kind : V.abs_kind) (rgl : A.abs_region_group list) + (region_can_end : T.RegionGroupId.id -> bool) + (compute_abs_avalues : + V.abs -> C.eval_ctx -> C.eval_ctx * V.typed_avalue list) + (ctx : C.eval_ctx) : C.eval_ctx = + (* Initialize the abstractions as empty (i.e., with no avalues) abstractions *) + let empty_absl = + create_empty_abstractions_from_abs_region_groups call_id kind rgl + region_can_end + in + + (* Compute and add the avalues to the abstractions, the insert the abstractions + * in the context. *) + let insert_abs (ctx : C.eval_ctx) (abs : V.abs) : C.eval_ctx = + (* Compute the values to insert in the abstraction *) + let ctx, avalues = compute_abs_avalues abs ctx in + (* Add the avalues to the abstraction *) + let abs = { abs with avalues } in + (* Insert the abstraction in the context *) + let ctx = { ctx with env = Abs abs :: ctx.env } in + (* Return *) + ctx + in + List.fold_left insert_abs ctx empty_absl + +(** Evaluate a statement *) +let rec eval_statement (config : C.config) (st : A.statement) : st_cm_fun = + fun cf ctx -> + (* Debugging *) + log#ldebug + (lazy + ("\n**About to evaluate statement**: [\n" + ^ statement_to_string_with_tab ctx st + ^ "\n]\n\n**Context**:\n" ^ eval_ctx_to_string ctx ^ "\n\n")); + + (* Expand the symbolic values if necessary - we need to do that before + * checking the invariants *) + let cc = greedy_expand_symbolic_values config in + (* Sanity check *) + let cc = comp cc (Inv.cf_check_invariants config) in + + (* Evaluate *) + let cf_eval_st cf : m_fun = + fun ctx -> + match st.content with + | A.Assign (p, rvalue) -> + (* Evaluate the rvalue *) + let cf_eval_rvalue = eval_rvalue config rvalue in + (* Assign *) + let cf_assign cf (res : (V.typed_value, eval_error) result) ctx = + log#ldebug + (lazy + ("about to assign to place: " ^ place_to_string ctx p + ^ "\n- Context:\n" ^ eval_ctx_to_string ctx)); + match res with + | Error EPanic -> cf Panic ctx + | Ok rv -> ( + let expr = assign_to_place config rv p (cf Unit) ctx in + (* Update the synthesized AST - here we store meta-information. + * We do it only in specific cases (it is not always useful, and + * also it can lead to issues - for instance, if we borrow an + * inactivated borrow, we later can't translate it to pure values...) *) + match rvalue with + | E.Use _ + | E.Ref (_, (E.Shared | E.Mut | E.TwoPhaseMut)) + | E.UnaryOp _ | E.BinaryOp _ | E.Discriminant _ | E.Aggregate _ -> + let rp = rvalue_get_place rvalue in + let rp = + match rp with + | Some rp -> Some (S.mk_mplace rp ctx) + | None -> None + in + S.synthesize_assignment (S.mk_mplace p ctx) rv rp expr) + in + + (* Compose and apply *) + comp cf_eval_rvalue cf_assign cf ctx + | A.AssignGlobal { dst; global } -> eval_global config dst global cf ctx + | A.FakeRead p -> + let expand_prim_copy = false in + let cf_prepare cf = + access_rplace_reorganize_and_read config expand_prim_copy Read p cf + in + let cf_continue cf v : m_fun = + fun ctx -> + assert (not (bottom_in_value ctx.ended_regions v)); + cf ctx + in + comp cf_prepare cf_continue (cf Unit) ctx + | A.SetDiscriminant (p, variant_id) -> + set_discriminant config p variant_id cf ctx + | A.Drop p -> drop_value config p (cf Unit) ctx + | A.Assert assertion -> eval_assertion config assertion cf ctx + | A.Call call -> eval_function_call config call cf ctx + | A.Panic -> cf Panic ctx + | A.Return -> cf Return ctx + | A.Break i -> cf (Break i) ctx + | A.Continue i -> cf (Continue i) ctx + | A.Nop -> cf Unit ctx + | A.Sequence (st1, st2) -> + (* Evaluate the first statement *) + let cf_st1 = eval_statement config st1 in + (* Evaluate the sequence *) + let cf_st2 cf res = + match res with + (* Evaluation successful: evaluate the second statement *) + | Unit -> eval_statement config st2 cf + (* Control-flow break: transmit. We enumerate the cases on purpose *) + | Panic | Break _ | Continue _ | Return -> cf res + in + (* Compose and apply *) + comp cf_st1 cf_st2 cf ctx + | A.Loop loop_body -> + (* For now, we don't support loops in symbolic mode *) + assert (config.C.mode = C.ConcreteMode); + (* Continuation for after we evaluate the loop body: depending the result + of doing one loop iteration: + - redoes a loop iteration + - exits the loop + - other... + + We need a specific function because of the {!Continue} case: in case we + continue, we might have to reevaluate the current loop body with the + new context (and repeat this an indefinite number of times). + *) + let rec reeval_loop_body res : m_fun = + match res with + | Return | Panic -> cf res + | Break i -> + (* Break out of the loop by calling the continuation *) + let res = if i = 0 then Unit else Break (i - 1) in + cf res + | Continue 0 -> + (* Re-evaluate the loop body *) + eval_statement config loop_body reeval_loop_body + | Continue i -> + (* Continue to an outer loop *) + cf (Continue (i - 1)) + | Unit -> + (* We can't get there. + * Note that if we decide not to fail here but rather do + * the same thing as for [Continue 0], we could make the + * code slightly simpler: calling {!reeval_loop_body} with + * {!Unit} would account for the first iteration of the loop. + * We prefer to write it this way for consistency and sanity, + * though. *) + raise (Failure "Unreachable") + in + (* Apply *) + eval_statement config loop_body reeval_loop_body ctx + | A.Switch (op, tgts) -> eval_switch config op tgts cf ctx + in + (* Compose and apply *) + comp cc cf_eval_st cf ctx + +and eval_global (config : C.config) (dest : V.VarId.id) + (gid : LA.GlobalDeclId.id) : st_cm_fun = + fun cf ctx -> + let global = C.ctx_lookup_global_decl ctx gid in + let place = { E.var_id = dest; projection = [] } in + match config.mode with + | ConcreteMode -> + (* Treat the evaluation of the global as a call to the global body (without arguments) *) + (eval_local_function_call_concrete config global.body_id [] [] [] place) + cf ctx + | SymbolicMode -> + (* Generate a fresh symbolic value. In the translation, this fresh symbolic value will be + * defined as equal to the value of the global (see {!S.synthesize_global_eval}). *) + let sval = + mk_fresh_symbolic_value V.Global (ety_no_regions_to_rty global.ty) + in + let cc = + assign_to_place config (mk_typed_value_from_symbolic_value sval) place + in + let e = cc (cf Unit) ctx in + S.synthesize_global_eval gid sval e + +(** Evaluate a switch *) +and eval_switch (config : C.config) (op : E.operand) (tgts : A.switch_targets) : + st_cm_fun = + fun cf ctx -> + (* We evaluate the operand in two steps: + * first we prepare it, then we check if its value is concrete or + * symbolic. If it is concrete, we can then evaluate the operand + * directly, otherwise we must first expand the value. + * Note that we can't fully evaluate the operand *then* expand the + * value if it is symbolic, because the value may have been move + * (and would thus floating in thin air...)! + * *) + (* Prepare the operand *) + let cf_eval_op cf : m_fun = eval_operand config op cf in + (* Match on the targets *) + let cf_match (cf : st_m_fun) (op_v : V.typed_value) : m_fun = + fun ctx -> + match tgts with + | A.If (st1, st2) -> ( + match op_v.value with + | V.Concrete (V.Bool b) -> + (* Evaluate the if and the branch body *) + let cf_branch cf : m_fun = + (* Branch *) + if b then eval_statement config st1 cf + else eval_statement config st2 cf + in + (* Compose the continuations *) + cf_branch cf ctx + | V.Symbolic sv -> + (* Expand the symbolic boolean, and continue by evaluating + * the branches *) + let cf_true : m_fun = eval_statement config st1 cf in + let cf_false : m_fun = eval_statement config st2 cf in + expand_symbolic_bool config sv + (S.mk_opt_place_from_op op ctx) + cf_true cf_false ctx + | _ -> raise (Failure "Inconsistent state")) + | A.SwitchInt (int_ty, stgts, otherwise) -> ( + match op_v.value with + | V.Concrete (V.Scalar sv) -> + (* Evaluate the branch *) + let cf_eval_branch cf = + (* Sanity check *) + assert (sv.V.int_ty = int_ty); + (* Find the branch *) + match List.find_opt (fun (svl, _) -> List.mem sv svl) stgts with + | None -> eval_statement config otherwise cf + | Some (_, tgt) -> eval_statement config tgt cf + in + (* Compose *) + cf_eval_branch cf ctx + | V.Symbolic sv -> + (* Expand the symbolic value and continue by evaluating the + * proper branches *) + let stgts = + List.map + (fun (cv, tgt_st) -> (cv, eval_statement config tgt_st cf)) + stgts + in + (* Several branches may be grouped together: every branch is described + * by a pair (list of values, branch expression). + * In order to do a symbolic evaluation, we make this "flat" by + * de-grouping the branches. *) + let stgts = + List.concat + (List.map + (fun (vl, st) -> List.map (fun v -> (v, st)) vl) + stgts) + in + (* Translate the otherwise branch *) + let otherwise = eval_statement config otherwise cf in + (* Expand and continue *) + expand_symbolic_int config sv + (S.mk_opt_place_from_op op ctx) + int_ty stgts otherwise ctx + | _ -> raise (Failure "Inconsistent state")) + in + (* Compose the continuations *) + comp cf_eval_op cf_match cf ctx + +(** Evaluate a function call (auxiliary helper for [eval_statement]) *) +and eval_function_call (config : C.config) (call : A.call) : st_cm_fun = + (* There are two cases: + - this is a local function, in which case we execute its body + - this is a non-local function, in which case there is a special treatment + *) + match call.func with + | A.Regular fid -> + eval_local_function_call config fid call.region_args call.type_args + call.args call.dest + | A.Assumed fid -> + eval_non_local_function_call config fid call.region_args call.type_args + call.args call.dest + +(** Evaluate a local (i.e., non-assumed) function call in concrete mode *) +and eval_local_function_call_concrete (config : C.config) (fid : A.FunDeclId.id) + (region_args : T.erased_region list) (type_args : T.ety list) + (args : E.operand list) (dest : E.place) : st_cm_fun = + fun cf ctx -> + assert (region_args = []); + + (* Retrieve the (correctly instantiated) body *) + let def = C.ctx_lookup_fun_decl ctx fid in + (* We can evaluate the function call only if it is not opaque *) + let body = + match def.body with + | None -> + raise + (Failure + ("Can't evaluate a call to an opaque function: " + ^ Print.name_to_string def.name)) + | Some body -> body + in + let tsubst = + Subst.make_type_subst + (List.map (fun v -> v.T.index) def.A.signature.type_params) + type_args + in + let locals, body_st = Subst.fun_body_substitute_in_body tsubst body in + + (* Evaluate the input operands *) + assert (List.length args = body.A.arg_count); + let cc = eval_operands config args in + + (* Push a frame delimiter - we use {!comp_transmit} to transmit the result + * of the operands evaluation from above to the functions afterwards, while + * ignoring it in this function *) + let cc = comp_transmit cc push_frame in + + (* Compute the initial values for the local variables *) + (* 1. Push the return value *) + let ret_var, locals = + match locals with + | ret_ty :: locals -> (ret_ty, locals) + | _ -> raise (Failure "Unreachable") + in + let input_locals, locals = + Collections.List.split_at locals body.A.arg_count + in + + let cc = comp_transmit cc (push_var ret_var (mk_bottom ret_var.var_ty)) in + + (* 2. Push the input values *) + let cf_push_inputs cf args = + let inputs = List.combine input_locals args in + (* Note that this function checks that the variables and their values + * have the same type (this is important) *) + push_vars inputs cf + in + let cc = comp cc cf_push_inputs in + + (* 3. Push the remaining local variables (initialized as {!Bottom}) *) + let cc = comp cc (push_uninitialized_vars locals) in + + (* Execute the function body *) + let cc = comp cc (eval_function_body config body_st) in + + (* Pop the stack frame and move the return value to its destination *) + let cf_finish cf res = + match res with + | Panic -> cf Panic + | Break _ | Continue _ | Unit -> raise (Failure "Unreachable") + | Return -> + (* Pop the stack frame, retrieve the return value, move it to + * its destination and continue *) + pop_frame_assign config dest (cf Unit) + in + let cc = comp cc cf_finish in + + (* Continue *) + cc cf ctx + +(** Evaluate a local (i.e., non-assumed) function call in symbolic mode *) +and eval_local_function_call_symbolic (config : C.config) (fid : A.FunDeclId.id) + (region_args : T.erased_region list) (type_args : T.ety list) + (args : E.operand list) (dest : E.place) : st_cm_fun = + fun cf ctx -> + (* Retrieve the (correctly instantiated) signature *) + let def = C.ctx_lookup_fun_decl ctx fid in + let sg = def.A.signature in + (* Instantiate the signature and introduce fresh abstraction and region ids + * while doing so *) + let inst_sg = instantiate_fun_sig type_args sg in + (* Sanity check *) + assert (List.length args = List.length def.A.signature.inputs); + (* Evaluate the function call *) + eval_function_call_symbolic_from_inst_sig config (A.Regular fid) inst_sg + region_args type_args args dest cf ctx + +(** Evaluate a function call in symbolic mode by using the function signature. + + This allows us to factorize the evaluation of local and non-local function + calls in symbolic mode: only their signatures matter. + *) +and eval_function_call_symbolic_from_inst_sig (config : C.config) + (fid : A.fun_id) (inst_sg : A.inst_fun_sig) + (region_args : T.erased_region list) (type_args : T.ety list) + (args : E.operand list) (dest : E.place) : st_cm_fun = + fun cf ctx -> + assert (region_args = []); + (* Generate a fresh symbolic value for the return value *) + let ret_sv_ty = inst_sg.A.output in + let ret_spc = mk_fresh_symbolic_value V.FunCallRet ret_sv_ty in + let ret_value = mk_typed_value_from_symbolic_value ret_spc in + let ret_av regions = + mk_aproj_loans_value_from_symbolic_value regions ret_spc + in + let args_places = List.map (fun p -> S.mk_opt_place_from_op p ctx) args in + let dest_place = Some (S.mk_mplace dest ctx) in + + (* Evaluate the input operands *) + let cc = eval_operands config args in + + (* Generate the abstractions and insert them in the context *) + let abs_ids = List.map (fun rg -> rg.T.id) inst_sg.regions_hierarchy in + let cf_call cf (args : V.typed_value list) : m_fun = + fun ctx -> + let args_with_rtypes = List.combine args inst_sg.A.inputs in + + (* Check the type of the input arguments *) + assert ( + List.for_all + (fun ((arg, rty) : V.typed_value * T.rty) -> + arg.V.ty = Subst.erase_regions rty) + args_with_rtypes); + (* Check that the input arguments don't contain symbolic values that can't + * be fed to functions (i.e., symbolic values output from function return + * values and which contain borrows of borrows can't be used as function + * inputs *) + assert ( + List.for_all + (fun arg -> + not (value_has_ret_symbolic_value_with_borrow_under_mut ctx arg)) + args); + + (* Initialize the abstractions and push them in the context. + * First, we define the function which, given an initialized, empty + * abstraction, computes the avalues which should be inserted inside. + *) + let compute_abs_avalues (abs : V.abs) (ctx : C.eval_ctx) : + C.eval_ctx * V.typed_avalue list = + (* Project over the input values *) + let ctx, args_projs = + List.fold_left_map + (fun ctx (arg, arg_rty) -> + apply_proj_borrows_on_input_value config ctx abs.regions + abs.ancestors_regions arg arg_rty) + ctx args_with_rtypes + in + (* Group the input and output values *) + (ctx, List.append args_projs [ ret_av abs.regions ]) + in + (* Actually initialize and insert the abstractions *) + let call_id = C.fresh_fun_call_id () in + let region_can_end _ = true in + let ctx = + create_push_abstractions_from_abs_region_groups call_id V.FunCall + inst_sg.A.regions_hierarchy region_can_end compute_abs_avalues ctx + in + + (* Apply the continuation *) + let expr = cf ctx in + + (* Synthesize the symbolic AST *) + S.synthesize_regular_function_call fid call_id abs_ids type_args args + args_places ret_spc dest_place expr + in + let cc = comp cc cf_call in + + (* Move the return value to its destination *) + let cc = comp cc (assign_to_place config ret_value dest) in + + (* End the abstractions which don't contain loans and don't have parent + * abstractions. + * We do the general, nested borrows case here: we end abstractions, then + * retry (because then we might end their children abstractions) + *) + let abs_ids = ref abs_ids in + let rec end_abs_with_no_loans cf : m_fun = + fun ctx -> + (* Find the abstractions which don't contain loans *) + let no_loans_abs, with_loans_abs = + List.partition + (fun abs_id -> + (* Lookup the abstraction *) + let abs = C.ctx_lookup_abs ctx abs_id in + (* Check if it has parents *) + V.AbstractionId.Set.is_empty abs.parents + (* Check if it contains non-ignored loans *) + && Option.is_none + (InterpreterBorrowsCore + .get_first_non_ignored_aloan_in_abstraction abs)) + !abs_ids + in + (* Check if there are abstractions to end *) + if no_loans_abs <> [] then ( + (* Update the reference to the list of asbtraction ids, for the recursive calls *) + abs_ids := with_loans_abs; + (* End the abstractions which can be ended *) + let no_loans_abs = V.AbstractionId.Set.of_list no_loans_abs in + let cc = InterpreterBorrows.end_abstractions config [] no_loans_abs in + (* Recursive call *) + let cc = comp cc end_abs_with_no_loans in + (* Continue *) + cc cf ctx) + else (* No abstractions to end: continue *) + cf ctx + in + (* Try to end the abstractions with no loans if: + * - the option is enabled + * - the function returns unit + * (see the documentation of {!config} for more information) + *) + let cc = + if config.return_unit_end_abs_with_no_loans && ty_is_unit inst_sg.output + then comp cc end_abs_with_no_loans + else cc + in + + (* Continue - note that we do as if the function call has been successful, + * by giving {!Unit} to the continuation, because we place us in the case + * where we haven't panicked. Of course, the translation needs to take the + * panic case into account... *) + cc (cf Unit) ctx + +(** Evaluate a non-local function call in symbolic mode *) +and eval_non_local_function_call_symbolic (config : C.config) + (fid : A.assumed_fun_id) (region_args : T.erased_region list) + (type_args : T.ety list) (args : E.operand list) (dest : E.place) : + st_cm_fun = + fun cf ctx -> + (* Sanity check: make sure the type parameters don't contain regions - + * this is a current limitation of our synthesis *) + assert ( + List.for_all + (fun ty -> not (ty_has_borrows ctx.type_context.type_infos ty)) + type_args); + + (* There are two cases (and this is extremely annoying): + - the function is not box_free + - the function is box_free + See {!eval_box_free} + *) + match fid with + | A.BoxFree -> + (* Degenerate case: box_free - note that this is not really a function + * call: no need to call a "synthesize_..." function *) + eval_box_free config region_args type_args args dest (cf Unit) ctx + | _ -> + (* "Normal" case: not box_free *) + (* In symbolic mode, the behaviour of a function call is completely defined + * by the signature of the function: we thus simply generate correctly + * instantiated signatures, and delegate the work to an auxiliary function *) + let inst_sig = + match fid with + | A.BoxFree -> + (* should have been treated above *) + raise (Failure "Unreachable") + | _ -> instantiate_fun_sig type_args (Assumed.get_assumed_sig fid) + in + + (* Evaluate the function call *) + eval_function_call_symbolic_from_inst_sig config (A.Assumed fid) inst_sig + region_args type_args args dest cf ctx + +(** Evaluate a non-local (i.e, assumed) function call such as [Box::deref] + (auxiliary helper for [eval_statement]) *) +and eval_non_local_function_call (config : C.config) (fid : A.assumed_fun_id) + (region_args : T.erased_region list) (type_args : T.ety list) + (args : E.operand list) (dest : E.place) : st_cm_fun = + fun cf ctx -> + (* Debug *) + log#ldebug + (lazy + (let type_args = + "[" ^ String.concat ", " (List.map (ety_to_string ctx) type_args) ^ "]" + in + let args = + "[" ^ String.concat ", " (List.map (operand_to_string ctx) args) ^ "]" + in + let dest = place_to_string ctx dest in + "eval_non_local_function_call:\n- fid:" ^ A.show_assumed_fun_id fid + ^ "\n- type_args: " ^ type_args ^ "\n- args: " ^ args ^ "\n- dest: " + ^ dest)); + + match config.mode with + | C.ConcreteMode -> + eval_non_local_function_call_concrete config fid region_args type_args + args dest (cf Unit) ctx + | C.SymbolicMode -> + eval_non_local_function_call_symbolic config fid region_args type_args + args dest cf ctx + +(** Evaluate a local (i.e, not assumed) function call (auxiliary helper for + [eval_statement]) *) +and eval_local_function_call (config : C.config) (fid : A.FunDeclId.id) + (region_args : T.erased_region list) (type_args : T.ety list) + (args : E.operand list) (dest : E.place) : st_cm_fun = + match config.mode with + | ConcreteMode -> + eval_local_function_call_concrete config fid region_args type_args args + dest + | SymbolicMode -> + eval_local_function_call_symbolic config fid region_args type_args args + dest + +(** Evaluate a statement seen as a function body (auxiliary helper for + [eval_statement]) *) +and eval_function_body (config : C.config) (body : A.statement) : st_cm_fun = + fun cf ctx -> + let cc = eval_statement config body in + let cf_finish cf res = + (* Note that we *don't* check the result ({!Panic}, {!Return}, etc.): we + * delegate the check to the caller. *) + (* Expand the symbolic values if necessary - we need to do that before + * checking the invariants *) + let cc = greedy_expand_symbolic_values config in + (* Sanity check *) + let cc = comp_check_ctx cc (Inv.check_invariants config) in + (* Continue *) + cc (cf res) + in + (* Compose and continue *) + comp cc cf_finish cf ctx diff --git a/compiler/InterpreterUtils.ml b/compiler/InterpreterUtils.ml new file mode 100644 index 00000000..e6033e9e --- /dev/null +++ b/compiler/InterpreterUtils.ml @@ -0,0 +1,245 @@ +module T = Types +module V = Values +module E = Expressions +module C = Contexts +module Subst = Substitute +module A = LlbcAst +module L = Logging +open Utils +open TypesUtils +module PA = Print.EvalCtxLlbcAst + +(** Some utilities *) + +let eval_ctx_to_string = Print.Contexts.eval_ctx_to_string +let ety_to_string = PA.ety_to_string +let rty_to_string = PA.rty_to_string +let symbolic_value_to_string = PA.symbolic_value_to_string +let borrow_content_to_string = PA.borrow_content_to_string +let loan_content_to_string = PA.loan_content_to_string +let aborrow_content_to_string = PA.aborrow_content_to_string +let aloan_content_to_string = PA.aloan_content_to_string +let aproj_to_string = PA.aproj_to_string +let typed_value_to_string = PA.typed_value_to_string +let typed_avalue_to_string = PA.typed_avalue_to_string +let place_to_string = PA.place_to_string +let operand_to_string = PA.operand_to_string +let statement_to_string ctx = PA.statement_to_string ctx "" " " +let statement_to_string_with_tab ctx = PA.statement_to_string ctx " " " " + +let same_symbolic_id (sv0 : V.symbolic_value) (sv1 : V.symbolic_value) : bool = + sv0.V.sv_id = sv1.V.sv_id + +let mk_var (index : V.VarId.id) (name : string option) (var_ty : T.ety) : A.var + = + { A.index; name; var_ty } + +(** Small helper - TODO: move *) +let mk_place_from_var_id (var_id : V.VarId.id) : E.place = + { var_id; projection = [] } + +(** Create a fresh symbolic value *) +let mk_fresh_symbolic_value (sv_kind : V.sv_kind) (ty : T.rty) : + V.symbolic_value = + let sv_id = C.fresh_symbolic_value_id () in + let svalue = { V.sv_kind; V.sv_id; V.sv_ty = ty } in + svalue + +(** Create a fresh symbolic value *) +let mk_fresh_symbolic_typed_value (sv_kind : V.sv_kind) (rty : T.rty) : + V.typed_value = + let ty = Subst.erase_regions rty in + (* Generate the fresh a symbolic value *) + let value = mk_fresh_symbolic_value sv_kind rty in + let value = V.Symbolic value in + { V.value; V.ty } + +(** Create a typed value from a symbolic value. *) +let mk_typed_value_from_symbolic_value (svalue : V.symbolic_value) : + V.typed_value = + let av = V.Symbolic svalue in + let av : V.typed_value = + { V.value = av; V.ty = Subst.erase_regions svalue.V.sv_ty } + in + av + +(** Create a loans projector value from a symbolic value. + + Checks if the projector will actually project some regions. If not, + returns {!V.AIgnored} ([_]). + + TODO: update to handle 'static + *) +let mk_aproj_loans_value_from_symbolic_value (regions : T.RegionId.Set.t) + (svalue : V.symbolic_value) : V.typed_avalue = + if ty_has_regions_in_set regions svalue.sv_ty then + let av = V.ASymbolic (V.AProjLoans (svalue, [])) in + let av : V.typed_avalue = { V.value = av; V.ty = svalue.V.sv_ty } in + av + else { V.value = V.AIgnored; ty = svalue.V.sv_ty } + +(** Create a borrows projector from a symbolic value *) +let mk_aproj_borrows_from_symbolic_value (proj_regions : T.RegionId.Set.t) + (svalue : V.symbolic_value) (proj_ty : T.rty) : V.aproj = + if ty_has_regions_in_set proj_regions proj_ty then + V.AProjBorrows (svalue, proj_ty) + else V.AIgnoredProjBorrows + +(** TODO: move *) +let borrow_is_asb (bid : V.BorrowId.id) (asb : V.abstract_shared_borrow) : bool + = + match asb with + | V.AsbBorrow bid' -> bid' = bid + | V.AsbProjReborrows _ -> false + +(** TODO: move *) +let borrow_in_asb (bid : V.BorrowId.id) (asb : V.abstract_shared_borrows) : bool + = + List.exists (borrow_is_asb bid) asb + +(** TODO: move *) +let remove_borrow_from_asb (bid : V.BorrowId.id) + (asb : V.abstract_shared_borrows) : V.abstract_shared_borrows = + let removed = ref 0 in + let asb = + List.filter + (fun asb -> + if not (borrow_is_asb bid asb) then true + else ( + removed := !removed + 1; + false)) + asb + in + assert (!removed = 1); + asb + +(** We sometimes need to return a value whose type may vary depending on + whether we find it in a "concrete" value or an abstraction (ex.: loan + contents when we perform environment lookups by using borrow ids) *) +type ('a, 'b) concrete_or_abs = Concrete of 'a | Abstract of 'b + +(** Generic loan content: concrete or abstract *) +type g_loan_content = (V.loan_content, V.aloan_content) concrete_or_abs + +(** Generic borrow content: concrete or abstract *) +type g_borrow_content = (V.borrow_content, V.aborrow_content) concrete_or_abs + +type abs_or_var_id = AbsId of V.AbstractionId.id | VarId of V.VarId.id option + +(** Utility exception *) +exception FoundBorrowContent of V.borrow_content + +(** Utility exception *) +exception FoundLoanContent of V.loan_content + +(** Utility exception *) +exception FoundABorrowContent of V.aborrow_content + +(** Utility exception *) +exception FoundGBorrowContent of g_borrow_content + +(** Utility exception *) +exception FoundGLoanContent of g_loan_content + +(** Utility exception *) +exception FoundAProjBorrows of V.symbolic_value * T.rty + +let symbolic_value_id_in_ctx (sv_id : V.SymbolicValueId.id) (ctx : C.eval_ctx) : + bool = + let obj = + object + inherit [_] C.iter_eval_ctx as super + + method! visit_Symbolic _ sv = + if sv.V.sv_id = sv_id then raise Found else () + + method! visit_aproj env aproj = + (match aproj with + | AProjLoans (sv, _) | AProjBorrows (sv, _) -> + if sv.V.sv_id = sv_id then raise Found else () + | AEndedProjLoans _ | AEndedProjBorrows _ | AIgnoredProjBorrows -> ()); + super#visit_aproj env aproj + + method! visit_abstract_shared_borrows _ asb = + let visit (asb : V.abstract_shared_borrow) : unit = + match asb with + | V.AsbBorrow _ -> () + | V.AsbProjReborrows (sv, _) -> + if sv.V.sv_id = sv_id then raise Found else () + in + List.iter visit asb + end + in + (* We use exceptions *) + try + obj#visit_eval_ctx () ctx; + false + with Found -> true + +(** Check that a symbolic value doesn't contain ended regions. + + Note that we don't check that the set of ended regions is empty: we + check that the set of ended regions doesn't intersect the set of + regions used in the type (this is more general). +*) +let symbolic_value_has_ended_regions (ended_regions : T.RegionId.Set.t) + (s : V.symbolic_value) : bool = + let regions = rty_regions s.V.sv_ty in + not (T.RegionId.Set.disjoint regions ended_regions) + +(** Check if a {!type:V.value} contains [⊥]. + + Note that this function is very general: it also checks wether + symbolic values contain already ended regions. + *) +let bottom_in_value (ended_regions : T.RegionId.Set.t) (v : V.typed_value) : + bool = + let obj = + object + inherit [_] V.iter_typed_value + method! visit_Bottom _ = raise Found + + method! visit_symbolic_value _ s = + if symbolic_value_has_ended_regions ended_regions s then raise Found + else () + end + in + (* We use exceptions *) + try + obj#visit_typed_value () v; + false + with Found -> true + +let value_has_ret_symbolic_value_with_borrow_under_mut (ctx : C.eval_ctx) + (v : V.typed_value) : bool = + let obj = + object + inherit [_] V.iter_typed_value + + method! visit_symbolic_value _ s = + match s.sv_kind with + | V.FunCallRet -> + if ty_has_borrow_under_mut ctx.type_context.type_infos s.sv_ty then + raise Found + else () + | V.SynthInput | V.SynthInputGivenBack | V.FunCallGivenBack + | V.SynthRetGivenBack -> + () + | V.Global -> () + end + in + (* We use exceptions *) + try + obj#visit_typed_value () v; + false + with Found -> true + +(** Return the place used in an rvalue, if that makes sense. + This is used to compute meta-data, to find pretty names. + *) +let rvalue_get_place (rv : E.rvalue) : E.place option = + match rv with + | Use (Copy p | Move p) -> Some p + | Use (Constant _) -> None + | Ref (p, _) -> Some p + | UnaryOp _ | BinaryOp _ | Discriminant _ | Aggregate _ -> None diff --git a/compiler/Invariants.ml b/compiler/Invariants.ml new file mode 100644 index 00000000..4a3364a6 --- /dev/null +++ b/compiler/Invariants.ml @@ -0,0 +1,794 @@ +(* The following module defines functions to check that some invariants + * are always maintained by evaluation contexts *) + +module T = Types +module V = Values +module E = Expressions +module C = Contexts +module Subst = Substitute +module A = LlbcAst +module L = Logging +open Cps +open TypesUtils +open InterpreterUtils +open InterpreterBorrowsCore + +(** The local logger *) +let log = L.invariants_log + +type borrow_info = { + loan_kind : T.ref_kind; + loan_in_abs : bool; + (* true if the loan was found in an abstraction *) + loan_ids : V.BorrowId.Set.t; + borrow_ids : V.BorrowId.Set.t; +} +[@@deriving show] + +type outer_borrow_info = { + outer_borrow : bool; + (* true if the value is borrowed *) + outer_shared : bool; (* true if the value is borrowed as shared *) +} + +let set_outer_mut (info : outer_borrow_info) : outer_borrow_info = + { info with outer_borrow = true } + +let set_outer_shared (_info : outer_borrow_info) : outer_borrow_info = + { outer_borrow = true; outer_shared = true } + +let ids_reprs_to_string (indent : string) + (reprs : V.BorrowId.id V.BorrowId.Map.t) : string = + V.BorrowId.Map.to_string (Some indent) V.BorrowId.to_string reprs + +let borrows_infos_to_string (indent : string) + (infos : borrow_info V.BorrowId.Map.t) : string = + V.BorrowId.Map.to_string (Some indent) show_borrow_info infos + +type borrow_kind = Mut | Shared | Inactivated + +(** Check that: + - loans and borrows are correctly related + - a two-phase borrow can't point to a value inside an abstraction + *) +let check_loans_borrows_relation_invariant (ctx : C.eval_ctx) : unit = + (* Link all the borrow ids to a representant - necessary because of shared + * borrows/loans *) + let ids_reprs : V.BorrowId.id V.BorrowId.Map.t ref = + ref V.BorrowId.Map.empty + in + (* Link all the id representants to a borrow information *) + let borrows_infos : borrow_info V.BorrowId.Map.t ref = + ref V.BorrowId.Map.empty + in + let context_to_string () : string = + eval_ctx_to_string ctx ^ "- representants:\n" + ^ ids_reprs_to_string " " !ids_reprs + ^ "\n- info:\n" + ^ borrows_infos_to_string " " !borrows_infos + in + (* Ignored loans - when we find an ignored loan while building the borrows_infos + * map, we register it in this list; once the borrows_infos map is completely + * built, we check that all the borrow ids of the ignored loans are in this + * map *) + let ignored_loans : (T.ref_kind * V.BorrowId.id) list ref = ref [] in + + (* first, register all the loans *) + (* Some utilities to register the loans *) + let register_ignored_loan (rkind : T.ref_kind) (bid : V.BorrowId.id) : unit = + ignored_loans := (rkind, bid) :: !ignored_loans + in + + let register_shared_loan (loan_in_abs : bool) (bids : V.BorrowId.Set.t) : unit + = + let reprs = !ids_reprs in + let infos = !borrows_infos in + (* Use the first borrow id as representant *) + let repr_bid = V.BorrowId.Set.min_elt bids in + assert (not (V.BorrowId.Map.mem repr_bid infos)); + (* Insert the mappings to the representant *) + let reprs = + V.BorrowId.Set.fold + (fun bid reprs -> + assert (not (V.BorrowId.Map.mem bid reprs)); + V.BorrowId.Map.add bid repr_bid reprs) + bids reprs + in + (* Insert the loan info *) + let info = + { + loan_kind = T.Shared; + loan_in_abs; + loan_ids = bids; + borrow_ids = V.BorrowId.Set.empty; + } + in + let infos = V.BorrowId.Map.add repr_bid info infos in + (* Update *) + ids_reprs := reprs; + borrows_infos := infos + in + + let register_mut_loan (loan_in_abs : bool) (bid : V.BorrowId.id) : unit = + let reprs = !ids_reprs in + let infos = !borrows_infos in + (* Sanity checks *) + assert (not (V.BorrowId.Map.mem bid reprs)); + assert (not (V.BorrowId.Map.mem bid infos)); + (* Add the mapping for the representant *) + let reprs = V.BorrowId.Map.add bid bid reprs in + (* Add the mapping for the loan info *) + let info = + { + loan_kind = T.Mut; + loan_in_abs; + loan_ids = V.BorrowId.Set.singleton bid; + borrow_ids = V.BorrowId.Set.empty; + } + in + let infos = V.BorrowId.Map.add bid info infos in + (* Update *) + ids_reprs := reprs; + borrows_infos := infos + in + + let loans_visitor = + object + inherit [_] C.iter_eval_ctx as super + + method! visit_Var _ binder v = + let inside_abs = false in + super#visit_Var inside_abs binder v + + method! visit_Abs _ abs = + let inside_abs = true in + super#visit_Abs inside_abs abs + + method! visit_loan_content inside_abs lc = + (* Register the loan *) + let _ = + match lc with + | V.SharedLoan (bids, _) -> register_shared_loan inside_abs bids + | V.MutLoan bid -> register_mut_loan inside_abs bid + in + (* Continue exploring *) + super#visit_loan_content inside_abs lc + + method! visit_aloan_content inside_abs lc = + let _ = + match lc with + | V.AMutLoan (bid, _) -> register_mut_loan inside_abs bid + | V.ASharedLoan (bids, _, _) -> register_shared_loan inside_abs bids + | V.AIgnoredMutLoan (bid, _) -> register_ignored_loan T.Mut bid + | V.AIgnoredSharedLoan _ + | V.AEndedMutLoan { given_back = _; child = _; given_back_meta = _ } + | V.AEndedSharedLoan (_, _) + | V.AEndedIgnoredMutLoan + { given_back = _; child = _; given_back_meta = _ } -> + (* Do nothing *) + () + in + (* Continue exploring *) + super#visit_aloan_content inside_abs lc + end + in + + (* Visit *) + let inside_abs = false in + loans_visitor#visit_eval_ctx inside_abs ctx; + + (* Then, register all the borrows *) + (* Some utilities to register the borrows *) + let find_info (bid : V.BorrowId.id) : borrow_info = + (* Find the representant *) + match V.BorrowId.Map.find_opt bid !ids_reprs with + | Some repr_bid -> + (* Lookup the info *) + V.BorrowId.Map.find repr_bid !borrows_infos + | None -> + let err = + "find_info: could not find the representant of borrow " + ^ V.BorrowId.to_string bid ^ ":\nContext:\n" ^ context_to_string () + in + log#serror err; + failwith err + in + + let update_info (bid : V.BorrowId.id) (info : borrow_info) : unit = + (* Find the representant *) + let repr_bid = V.BorrowId.Map.find bid !ids_reprs in + (* Update the info *) + let infos = + V.BorrowId.Map.update repr_bid + (fun x -> + match x with Some _ -> Some info | None -> failwith "Unreachable") + !borrows_infos + in + borrows_infos := infos + in + + let register_ignored_borrow = register_ignored_loan in + + let register_borrow (kind : borrow_kind) (bid : V.BorrowId.id) : unit = + (* Lookup the info *) + let info = find_info bid in + (* Check that the borrow kind is consistent *) + (match (info.loan_kind, kind) with + | T.Shared, (Shared | Inactivated) | T.Mut, Mut -> () + | _ -> failwith "Invariant not satisfied"); + (* An inactivated borrow can't point to a value inside an abstraction *) + assert (kind <> Inactivated || not info.loan_in_abs); + (* Insert the borrow id *) + let borrow_ids = info.borrow_ids in + assert (not (V.BorrowId.Set.mem bid borrow_ids)); + let info = { info with borrow_ids = V.BorrowId.Set.add bid borrow_ids } in + (* Update the info in the map *) + update_info bid info + in + + let borrows_visitor = + object + inherit [_] C.iter_eval_ctx as super + + method! visit_abstract_shared_borrows _ asb = + let visit asb = + match asb with + | V.AsbBorrow bid -> register_borrow Shared bid + | V.AsbProjReborrows _ -> () + in + List.iter visit asb + + method! visit_borrow_content env bc = + (* Register the loan *) + let _ = + match bc with + | V.SharedBorrow (_, bid) -> register_borrow Shared bid + | V.MutBorrow (bid, _) -> register_borrow Mut bid + | V.InactivatedMutBorrow (_, bid) -> register_borrow Inactivated bid + in + (* Continue exploring *) + super#visit_borrow_content env bc + + method! visit_aborrow_content env bc = + let _ = + match bc with + | V.AMutBorrow (_, bid, _) -> register_borrow Mut bid + | V.ASharedBorrow bid -> register_borrow Shared bid + | V.AIgnoredMutBorrow (Some bid, _) -> register_ignored_borrow Mut bid + | V.AIgnoredMutBorrow (None, _) + | V.AEndedMutBorrow _ | V.AEndedIgnoredMutBorrow _ + | V.AEndedSharedBorrow | V.AProjSharedBorrow _ -> + (* Do nothing *) + () + in + (* Continue exploring *) + super#visit_aborrow_content env bc + end + in + + (* Visit *) + borrows_visitor#visit_eval_ctx () ctx; + + (* Debugging *) + log#ldebug + (lazy ("\nAbout to check context invariant:\n" ^ context_to_string ())); + + (* Finally, check that everything is consistant *) + (* First, check all the ignored loans are present at the proper place *) + List.iter + (fun (rkind, bid) -> + let info = find_info bid in + assert (info.loan_kind = rkind)) + !ignored_loans; + + (* Then, check the borrow infos *) + V.BorrowId.Map.iter + (fun _ info -> + (* Note that we can't directly compare the sets - I guess they are + * different depending on the order in which we add the elements... *) + assert ( + V.BorrowId.Set.elements info.loan_ids + = V.BorrowId.Set.elements info.borrow_ids); + match info.loan_kind with + | T.Mut -> assert (V.BorrowId.Set.cardinal info.loan_ids = 1) + | T.Shared -> ()) + !borrows_infos + +(** Check that: + - borrows/loans can't contain ⊥ or inactivated mut borrows + - shared loans can't contain mutable loans + *) +let check_borrowed_values_invariant (config : C.config) (ctx : C.eval_ctx) : + unit = + let visitor = + object + inherit [_] C.iter_eval_ctx as super + + method! visit_Bottom info = + (* No ⊥ inside borrowed values *) + assert (config.C.allow_bottom_below_borrow || not info.outer_borrow) + + method! visit_ABottom _info = + (* ⊥ inside an abstraction is not the same as in a regular value *) + () + + method! visit_loan_content info lc = + (* Update the info *) + let info = + match lc with + | V.SharedLoan (_, _) -> set_outer_shared info + | V.MutLoan _ -> + (* No mutable loan inside a shared loan *) + assert (not info.outer_shared); + set_outer_mut info + in + (* Continue exploring *) + super#visit_loan_content info lc + + method! visit_borrow_content info bc = + (* Update the info *) + let info = + match bc with + | V.SharedBorrow _ -> set_outer_shared info + | V.InactivatedMutBorrow _ -> + assert (not info.outer_borrow); + set_outer_shared info + | V.MutBorrow (_, _) -> set_outer_mut info + in + (* Continue exploring *) + super#visit_borrow_content info bc + + method! visit_aloan_content info lc = + (* Update the info *) + let info = + match lc with + | V.AMutLoan (_, _) -> set_outer_mut info + | V.ASharedLoan (_, _, _) -> set_outer_shared info + | V.AEndedMutLoan { given_back = _; child = _; given_back_meta = _ } + -> + set_outer_mut info + | V.AEndedSharedLoan (_, _) -> set_outer_shared info + | V.AIgnoredMutLoan (_, _) -> set_outer_mut info + | V.AEndedIgnoredMutLoan + { given_back = _; child = _; given_back_meta = _ } -> + set_outer_mut info + | V.AIgnoredSharedLoan _ -> set_outer_shared info + in + (* Continue exploring *) + super#visit_aloan_content info lc + + method! visit_aborrow_content info bc = + (* Update the info *) + let info = + match bc with + | V.AMutBorrow (_, _, _) -> set_outer_mut info + | V.ASharedBorrow _ | V.AEndedSharedBorrow -> set_outer_shared info + | V.AIgnoredMutBorrow _ | V.AEndedMutBorrow _ + | V.AEndedIgnoredMutBorrow _ -> + set_outer_mut info + | V.AProjSharedBorrow _ -> set_outer_shared info + in + (* Continue exploring *) + super#visit_aborrow_content info bc + end + in + + (* Explore *) + let info = { outer_borrow = false; outer_shared = false } in + visitor#visit_eval_ctx info ctx + +let check_constant_value_type (cv : V.constant_value) (ty : T.ety) : unit = + match (cv, ty) with + | V.Scalar sv, T.Integer int_ty -> assert (sv.int_ty = int_ty) + | V.Bool _, T.Bool | V.Char _, T.Char | V.String _, T.Str -> () + | _ -> failwith "Erroneous typing" + +let check_typing_invariant (ctx : C.eval_ctx) : unit = + (* TODO: the type of aloans doens't make sense: they have a type + * of the shape [& (mut) T] where they should have type [T]... + * This messes a bit the type invariant checks when checking the + * children. In order to isolate the problem (for future modifications) + * we introduce function, so that we can easily spot all the involved + * places. + * *) + let aloan_get_expected_child_type (ty : 'r T.ty) : 'r T.ty = + let _, ty, _ = ty_get_ref ty in + ty + in + + let visitor = + object + inherit [_] C.iter_eval_ctx as super + method! visit_abs _ abs = super#visit_abs (Some abs) abs + + method! visit_typed_value info tv = + (* Check the current pair (value, type) *) + (match (tv.V.value, tv.V.ty) with + | V.Concrete cv, ty -> check_constant_value_type cv ty + (* ADT case *) + | V.Adt av, T.Adt (T.AdtId def_id, regions, tys) -> + (* Retrieve the definition to check the variant id, the number of + * parameters, etc. *) + let def = C.ctx_lookup_type_decl ctx def_id in + (* Check the number of parameters *) + assert (List.length regions = List.length def.region_params); + assert (List.length tys = List.length def.type_params); + (* Check that the variant id is consistent *) + (match (av.V.variant_id, def.T.kind) with + | Some variant_id, T.Enum variants -> + assert (T.VariantId.to_int variant_id < List.length variants) + | None, T.Struct _ -> () + | _ -> failwith "Erroneous typing"); + (* Check that the field types are correct *) + let field_types = + Subst.type_decl_get_instantiated_field_etypes def av.V.variant_id + tys + in + let fields_with_types = + List.combine av.V.field_values field_types + in + List.iter + (fun ((v, ty) : V.typed_value * T.ety) -> assert (v.V.ty = ty)) + fields_with_types + (* Tuple case *) + | V.Adt av, T.Adt (T.Tuple, regions, tys) -> + assert (regions = []); + assert (av.V.variant_id = None); + (* Check that the fields have the proper values - and check that there + * are as many fields as field types at the same time *) + let fields_with_types = List.combine av.V.field_values tys in + List.iter + (fun ((v, ty) : V.typed_value * T.ety) -> assert (v.V.ty = ty)) + fields_with_types + (* Assumed type case *) + | V.Adt av, T.Adt (T.Assumed aty_id, regions, tys) -> ( + assert (av.V.variant_id = None || aty_id = T.Option); + match (aty_id, av.V.field_values, regions, tys) with + (* Box *) + | T.Box, [ inner_value ], [], [ inner_ty ] + | T.Option, [ inner_value ], [], [ inner_ty ] -> + assert (inner_value.V.ty = inner_ty) + | T.Option, _, [], [ _ ] -> + (* Option::None: nothing to check *) + () + | T.Vec, fvs, [], [ vec_ty ] -> + List.iter + (fun (v : V.typed_value) -> assert (v.ty = vec_ty)) + fvs + | _ -> failwith "Erroneous type") + | V.Bottom, _ -> (* Nothing to check *) () + | V.Borrow bc, T.Ref (_, ref_ty, rkind) -> ( + match (bc, rkind) with + | V.SharedBorrow (_, bid), T.Shared + | V.InactivatedMutBorrow (_, bid), T.Mut -> ( + (* Lookup the borrowed value to check it has the proper type *) + let _, glc = lookup_loan ek_all bid ctx in + match glc with + | Concrete (V.SharedLoan (_, sv)) + | Abstract (V.ASharedLoan (_, sv, _)) -> + assert (sv.V.ty = ref_ty) + | _ -> failwith "Inconsistent context") + | V.MutBorrow (_, bv), T.Mut -> + assert ( + (* Check that the borrowed value has the proper type *) + bv.V.ty = ref_ty) + | _ -> failwith "Erroneous typing") + | V.Loan lc, ty -> ( + match lc with + | V.SharedLoan (_, sv) -> assert (sv.V.ty = ty) + | V.MutLoan bid -> ( + (* Lookup the borrowed value to check it has the proper type *) + let glc = lookup_borrow ek_all bid ctx in + match glc with + | Concrete (V.MutBorrow (_, bv)) -> assert (bv.V.ty = ty) + | Abstract (V.AMutBorrow (_, _, sv)) -> + assert (Subst.erase_regions sv.V.ty = ty) + | _ -> failwith "Inconsistent context")) + | V.Symbolic sv, ty -> + let ty' = Subst.erase_regions sv.V.sv_ty in + assert (ty' = ty) + | _ -> failwith "Erroneous typing"); + (* Continue exploring to inspect the subterms *) + super#visit_typed_value info tv + + (* TODO: there is a lot of duplication with {!visit_typed_value} + * which is quite annoying. There might be a way of factorizing + * that by factorizing the definitions of value and avalue, but + * the generation of visitors then doesn't work properly (TODO: + * report that). Still, it is actually not that problematic + * because this code shouldn't change a lot in the future, + * so the cost of maintenance should be pretty low. + * *) + method! visit_typed_avalue info atv = + (* Check the current pair (value, type) *) + (match (atv.V.value, atv.V.ty) with + | V.AConcrete cv, ty -> + check_constant_value_type cv (Subst.erase_regions ty) + (* ADT case *) + | V.AAdt av, T.Adt (T.AdtId def_id, regions, tys) -> + (* Retrieve the definition to check the variant id, the number of + * parameters, etc. *) + let def = C.ctx_lookup_type_decl ctx def_id in + (* Check the number of parameters *) + assert (List.length regions = List.length def.region_params); + assert (List.length tys = List.length def.type_params); + (* Check that the variant id is consistent *) + (match (av.V.variant_id, def.T.kind) with + | Some variant_id, T.Enum variants -> + assert (T.VariantId.to_int variant_id < List.length variants) + | None, T.Struct _ -> () + | _ -> failwith "Erroneous typing"); + (* Check that the field types are correct *) + let field_types = + Subst.type_decl_get_instantiated_field_rtypes def av.V.variant_id + regions tys + in + let fields_with_types = + List.combine av.V.field_values field_types + in + List.iter + (fun ((v, ty) : V.typed_avalue * T.rty) -> assert (v.V.ty = ty)) + fields_with_types + (* Tuple case *) + | V.AAdt av, T.Adt (T.Tuple, regions, tys) -> + assert (regions = []); + assert (av.V.variant_id = None); + (* Check that the fields have the proper values - and check that there + * are as many fields as field types at the same time *) + let fields_with_types = List.combine av.V.field_values tys in + List.iter + (fun ((v, ty) : V.typed_avalue * T.rty) -> assert (v.V.ty = ty)) + fields_with_types + (* Assumed type case *) + | V.AAdt av, T.Adt (T.Assumed aty_id, regions, tys) -> ( + assert (av.V.variant_id = None); + match (aty_id, av.V.field_values, regions, tys) with + (* Box *) + | T.Box, [ boxed_value ], [], [ boxed_ty ] -> + assert (boxed_value.V.ty = boxed_ty) + | _ -> failwith "Erroneous type") + | V.ABottom, _ -> (* Nothing to check *) () + | V.ABorrow bc, T.Ref (_, ref_ty, rkind) -> ( + match (bc, rkind) with + | V.AMutBorrow (_, _, av), T.Mut -> + (* Check that the child value has the proper type *) + assert (av.V.ty = ref_ty) + | V.ASharedBorrow bid, T.Shared -> ( + (* Lookup the borrowed value to check it has the proper type *) + let _, glc = lookup_loan ek_all bid ctx in + match glc with + | Concrete (V.SharedLoan (_, sv)) + | Abstract (V.ASharedLoan (_, sv, _)) -> + assert (sv.V.ty = Subst.erase_regions ref_ty) + | _ -> failwith "Inconsistent context") + | V.AIgnoredMutBorrow (_opt_bid, av), T.Mut -> + assert (av.V.ty = ref_ty) + | ( V.AEndedIgnoredMutBorrow + { given_back_loans_proj; child; given_back_meta = _ }, + T.Mut ) -> + assert (given_back_loans_proj.V.ty = ref_ty); + assert (child.V.ty = ref_ty) + | V.AProjSharedBorrow _, T.Shared -> () + | _ -> failwith "Inconsistent context") + | V.ALoan lc, aty -> ( + match lc with + | V.AMutLoan (bid, child_av) | V.AIgnoredMutLoan (bid, child_av) + -> ( + let borrowed_aty = aloan_get_expected_child_type aty in + assert (child_av.V.ty = borrowed_aty); + (* Lookup the borrowed value to check it has the proper type *) + let glc = lookup_borrow ek_all bid ctx in + match glc with + | Concrete (V.MutBorrow (_, bv)) -> + assert (bv.V.ty = Subst.erase_regions borrowed_aty) + | Abstract (V.AMutBorrow (_, _, sv)) -> + assert ( + Subst.erase_regions sv.V.ty + = Subst.erase_regions borrowed_aty) + | _ -> failwith "Inconsistent context") + | V.ASharedLoan (_, sv, child_av) | V.AEndedSharedLoan (sv, child_av) + -> + let borrowed_aty = aloan_get_expected_child_type aty in + assert (sv.V.ty = Subst.erase_regions borrowed_aty); + (* TODO: the type of aloans doesn't make sense, see above *) + assert (child_av.V.ty = borrowed_aty) + | V.AEndedMutLoan { given_back; child; given_back_meta = _ } + | V.AEndedIgnoredMutLoan { given_back; child; given_back_meta = _ } + -> + let borrowed_aty = aloan_get_expected_child_type aty in + assert (given_back.V.ty = borrowed_aty); + assert (child.V.ty = borrowed_aty) + | V.AIgnoredSharedLoan child_av -> + assert (child_av.V.ty = aloan_get_expected_child_type aty)) + | V.ASymbolic aproj, ty -> ( + let ty1 = Subst.erase_regions ty in + match aproj with + | V.AProjLoans (sv, _) -> + let ty2 = Subst.erase_regions sv.V.sv_ty in + assert (ty1 = ty2); + (* Also check that the symbolic values contain regions of interest - + * otherwise they should have been reduced to [_] *) + let abs = Option.get info in + assert (ty_has_regions_in_set abs.regions sv.V.sv_ty) + | V.AProjBorrows (sv, proj_ty) -> + let ty2 = Subst.erase_regions sv.V.sv_ty in + assert (ty1 = ty2); + (* Also check that the symbolic values contain regions of interest - + * otherwise they should have been reduced to [_] *) + let abs = Option.get info in + assert (ty_has_regions_in_set abs.regions proj_ty) + | V.AEndedProjLoans (_msv, given_back_ls) -> + List.iter + (fun (_, proj) -> + match proj with + | V.AProjBorrows (_sv, ty') -> assert (ty' = ty) + | V.AEndedProjBorrows _ | V.AIgnoredProjBorrows -> () + | _ -> failwith "Unexpected") + given_back_ls + | V.AEndedProjBorrows _ | V.AIgnoredProjBorrows -> ()) + | V.AIgnored, _ -> () + | _ -> failwith "Erroneous typing"); + (* Continue exploring to inspect the subterms *) + super#visit_typed_avalue info atv + end + in + visitor#visit_eval_ctx (None : V.abs option) ctx + +type proj_borrows_info = { + abs_id : V.AbstractionId.id; + regions : T.RegionId.Set.t; + proj_ty : T.rty; + as_shared_value : bool; (** True if the value is below a shared borrow *) +} +[@@deriving show] + +type proj_loans_info = { + abs_id : V.AbstractionId.id; + regions : T.RegionId.Set.t; +} +[@@deriving show] + +type sv_info = { + ty : T.rty; + env_count : int; + aproj_borrows : proj_borrows_info list; + aproj_loans : proj_loans_info list; +} +[@@deriving show] + +(** Check the invariants over the symbolic values. + + - a symbolic value can't be both in proj_borrows and in the concrete env + (this is why we preemptively expand copyable symbolic values) + - if a symbolic value contains regions: there is at most one occurrence + of this value in the concrete env + - if there is an aproj_borrows in the environment, there must also be a + corresponding aproj_loans + - aproj_loans are mutually disjoint + - TODO: aproj_borrows are mutually disjoint + - the union of the aproj_loans contains the aproj_borrows applied on the + same symbolic values + *) +let check_symbolic_values (_config : C.config) (ctx : C.eval_ctx) : unit = + (* Small utility *) + let module M = V.SymbolicValueId.Map in + let infos : sv_info M.t ref = ref M.empty in + let lookup_info (sv : V.symbolic_value) : sv_info = + match M.find_opt sv.V.sv_id !infos with + | Some info -> info + | None -> + { ty = sv.sv_ty; env_count = 0; aproj_borrows = []; aproj_loans = [] } + in + let update_info (sv : V.symbolic_value) (info : sv_info) = + infos := M.add sv.sv_id info !infos + in + let add_env_sv (sv : V.symbolic_value) : unit = + let info = lookup_info sv in + let info = { info with env_count = info.env_count + 1 } in + update_info sv info + in + let add_aproj_borrows (sv : V.symbolic_value) abs_id regions proj_ty + as_shared_value : unit = + let info = lookup_info sv in + let binfo = { abs_id; regions; proj_ty; as_shared_value } in + let info = { info with aproj_borrows = binfo :: info.aproj_borrows } in + update_info sv info + in + let add_aproj_loans (sv : V.symbolic_value) abs_id regions : unit = + let info = lookup_info sv in + let linfo = { abs_id; regions } in + let info = { info with aproj_loans = linfo :: info.aproj_loans } in + update_info sv info + in + (* Visitor *) + let obj = + object + inherit [_] C.iter_eval_ctx as super + method! visit_abs _ abs = super#visit_abs (Some abs) abs + method! visit_Symbolic _ sv = add_env_sv sv + + method! visit_abstract_shared_borrows abs asb = + let abs = Option.get abs in + let visit asb = + match asb with + | V.AsbBorrow _ -> () + | AsbProjReborrows (sv, proj_ty) -> + add_aproj_borrows sv abs.abs_id abs.regions proj_ty true + in + List.iter visit asb + + method! visit_aproj abs aproj = + (let abs = Option.get abs in + match aproj with + | AProjLoans (sv, _) -> add_aproj_loans sv abs.abs_id abs.regions + | AProjBorrows (sv, proj_ty) -> + add_aproj_borrows sv abs.abs_id abs.regions proj_ty false + | AEndedProjLoans _ | AEndedProjBorrows _ | AIgnoredProjBorrows -> ()); + super#visit_aproj abs aproj + end + in + (* Collect the information *) + obj#visit_eval_ctx None ctx; + log#ldebug + (lazy + ("check_symbolic_values: collected information:\n" + ^ V.SymbolicValueId.Map.to_string (Some " ") show_sv_info !infos)); + (* Check *) + let check_info _id info = + (* TODO: check that: + * - the borrows are mutually disjoint + *) + (* A symbolic value can't be both in the regular environment and inside + * projectors of borrows in abstractions *) + assert (info.env_count = 0 || info.aproj_borrows = []); + (* A symbolic value containing borrows can't be duplicated (i.e., copied): + * it must be expanded first *) + if ty_has_borrows ctx.type_context.type_infos info.ty then + assert (info.env_count <= 1); + (* A duplicated symbolic value is necessarily primitively copyable *) + assert (info.env_count <= 1 || ty_is_primitively_copyable info.ty); + + assert (info.aproj_borrows = [] || info.aproj_loans <> []); + (* At the same time: + * - check that the loans don't intersect + * - compute the set of regions for which we project loans + *) + (* Check that the loan projectors contain the region projectors *) + let loan_regions = + List.fold_left + (fun regions linfo -> + let regions = + T.RegionId.Set.fold + (fun rid regions -> + assert (not (T.RegionId.Set.mem rid regions)); + T.RegionId.Set.add rid regions) + regions linfo.regions + in + regions) + T.RegionId.Set.empty info.aproj_loans + in + (* Check that the union of the loan projectors contains the borrow projections. *) + List.iter + (fun binfo -> + assert ( + projection_contains info.ty loan_regions binfo.proj_ty binfo.regions)) + info.aproj_borrows; + () + in + + M.iter check_info !infos + +let check_invariants (config : C.config) (ctx : C.eval_ctx) : unit = + if config.C.check_invariants then ( + log#ldebug (lazy "Checking invariants"); + check_loans_borrows_relation_invariant ctx; + check_borrowed_values_invariant config ctx; + check_typing_invariant ctx; + check_symbolic_values config ctx) + else log#ldebug (lazy "Not checking invariants (check is not activated)") + +(** Same as {!check_invariants}, but written in CPS *) +let cf_check_invariants (config : C.config) : cm_fun = + fun cf ctx -> + check_invariants config ctx; + cf ctx diff --git a/compiler/LlbcAst.ml b/compiler/LlbcAst.ml new file mode 100644 index 00000000..1b08f1ea --- /dev/null +++ b/compiler/LlbcAst.ml @@ -0,0 +1,205 @@ +open Names +open Types +open Values +open Expressions +open Identifiers +module FunDeclId = IdGen () +module GlobalDeclId = IdGen () +open Meta + +(** A variable, as used in a function definition *) +type var = { + index : VarId.id; (** Unique variable identifier *) + name : string option; + var_ty : ety; + (** The variable type - erased type, because variables are not used + ** in function signatures: they are only used to declare the list of + ** variables manipulated by a function body *) +} +[@@deriving show] + +type assumed_fun_id = + | Replace (** [core::mem::replace] *) + | BoxNew + | BoxDeref (** [core::ops::deref::Deref::<alloc::boxed::Box<T>>::deref] *) + | BoxDerefMut + (** [core::ops::deref::DerefMut::<alloc::boxed::Box<T>>::deref_mut] *) + | BoxFree + | VecNew + | VecPush + | VecInsert + | VecLen + | VecIndex (** [core::ops::index::Index::index<alloc::vec::Vec<T>, usize>] *) + | VecIndexMut + (** [core::ops::index::IndexMut::index_mut<alloc::vec::Vec<T>, usize>] *) +[@@deriving show, ord] + +type fun_id = Regular of FunDeclId.id | Assumed of assumed_fun_id +[@@deriving show, ord] + +type global_assignment = { dst : VarId.id; global : GlobalDeclId.id } +[@@deriving show] + +type assertion = { cond : operand; expected : bool } [@@deriving show] + +type abs_region_group = (AbstractionId.id, RegionId.id) g_region_group +[@@deriving show] + +type abs_region_groups = (AbstractionId.id, RegionId.id) g_region_groups +[@@deriving show] + +(** A function signature, as used when declaring functions *) +type fun_sig = { + region_params : region_var list; + num_early_bound_regions : int; + regions_hierarchy : region_var_groups; + type_params : type_var list; + inputs : sty list; + output : sty; +} +[@@deriving show] + +(** A function signature, after instantiation *) +type inst_fun_sig = { + regions_hierarchy : abs_region_groups; + inputs : rty list; + output : rty; +} +[@@deriving show] + +type call = { + func : fun_id; + region_args : erased_region list; + type_args : ety list; + args : operand list; + dest : place; +} +[@@deriving show] + +(** Ancestor for [typed_value] iter visitor *) +class ['self] iter_statement_base = + object (_self : 'self) + inherit [_] VisitorsRuntime.iter + + method visit_global_assignment : 'env -> global_assignment -> unit = + fun _ _ -> () + + method visit_meta : 'env -> meta -> unit = fun _ _ -> () + method visit_place : 'env -> place -> unit = fun _ _ -> () + method visit_rvalue : 'env -> rvalue -> unit = fun _ _ -> () + method visit_id : 'env -> VariantId.id -> unit = fun _ _ -> () + method visit_assertion : 'env -> assertion -> unit = fun _ _ -> () + method visit_operand : 'env -> operand -> unit = fun _ _ -> () + method visit_call : 'env -> call -> unit = fun _ _ -> () + method visit_integer_type : 'env -> integer_type -> unit = fun _ _ -> () + method visit_scalar_value : 'env -> scalar_value -> unit = fun _ _ -> () + end + +(** Ancestor for [typed_value] map visitor *) +class ['self] map_statement_base = + object (_self : 'self) + inherit [_] VisitorsRuntime.map + + method visit_global_assignment + : 'env -> global_assignment -> global_assignment = + fun _ x -> x + + method visit_meta : 'env -> meta -> meta = fun _ x -> x + method visit_place : 'env -> place -> place = fun _ x -> x + method visit_rvalue : 'env -> rvalue -> rvalue = fun _ x -> x + method visit_id : 'env -> VariantId.id -> VariantId.id = fun _ x -> x + method visit_assertion : 'env -> assertion -> assertion = fun _ x -> x + method visit_operand : 'env -> operand -> operand = fun _ x -> x + method visit_call : 'env -> call -> call = fun _ x -> x + + method visit_integer_type : 'env -> integer_type -> integer_type = + fun _ x -> x + + method visit_scalar_value : 'env -> scalar_value -> scalar_value = + fun _ x -> x + end + +type statement = { + meta : meta; (** The statement meta-data *) + content : raw_statement; (** The statement itself *) +} + +and raw_statement = + | Assign of place * rvalue + | AssignGlobal of global_assignment + | FakeRead of place + | SetDiscriminant of place * VariantId.id + | Drop of place + | Assert of assertion + | Call of call + | Panic + | Return + | Break of int + (** Break to (outer) loop. The [int] identifies the loop to break to: + * 0: break to the first outer loop (the current loop) + * 1: break to the second outer loop + * ... + *) + | Continue of int + (** Continue to (outer) loop. The loop identifier works + the same way as for {!Break} *) + | Nop + | Sequence of statement * statement + | Switch of operand * switch_targets + | Loop of statement + +and switch_targets = + | If of statement * statement (** Gives the "if" and "else" blocks *) + | SwitchInt of integer_type * (scalar_value list * statement) list * statement + (** The targets for a switch over an integer are: + - the list [(matched values, statement to execute)] + We need a list for the matched values in case we do something like this: + [switch n { 0 | 1 => ..., _ => ... }] + - the "otherwise" statement + Also note that we precise the type of the integer (uint32, int64, etc.) + which we switch on. *) +[@@deriving + show, + visitors + { + name = "iter_statement"; + variety = "iter"; + ancestors = [ "iter_statement_base" ]; + nude = true (* Don't inherit {!VisitorsRuntime.iter} *); + concrete = true; + }, + visitors + { + name = "map_statement"; + variety = "map"; + ancestors = [ "map_statement_base" ]; + nude = true (* Don't inherit {!VisitorsRuntime.iter} *); + concrete = true; + }] + +type fun_body = { + meta : meta; + arg_count : int; + locals : var list; + body : statement; +} +[@@deriving show] + +type fun_decl = { + def_id : FunDeclId.id; + meta : meta; + name : fun_name; + signature : fun_sig; + body : fun_body option; + is_global_decl_body : bool; +} +[@@deriving show] + +type global_decl = { + def_id : GlobalDeclId.id; + meta : meta; + body_id : FunDeclId.id; + name : global_name; + ty : ety; +} +[@@deriving show] diff --git a/compiler/LlbcAstUtils.ml b/compiler/LlbcAstUtils.ml new file mode 100644 index 00000000..46711d0a --- /dev/null +++ b/compiler/LlbcAstUtils.ml @@ -0,0 +1,73 @@ +open LlbcAst +open Utils +module T = Types + +(** Check if a {!type:LlbcAst.statement} contains loops *) +let statement_has_loops (st : statement) : bool = + let obj = + object + inherit [_] iter_statement + method! visit_Loop _ _ = raise Found + end + in + try + obj#visit_statement () st; + false + with Found -> true + +(** Check if a {!type:LlbcAst.fun_decl} contains loops *) +let fun_decl_has_loops (fd : fun_decl) : bool = + match fd.body with + | Some body -> statement_has_loops body.body + | None -> false + +let lookup_fun_sig (fun_id : fun_id) (fun_decls : fun_decl FunDeclId.Map.t) : + fun_sig = + match fun_id with + | Regular id -> (FunDeclId.Map.find id fun_decls).signature + | Assumed aid -> Assumed.get_assumed_sig aid + +let lookup_fun_name (fun_id : fun_id) (fun_decls : fun_decl FunDeclId.Map.t) : + Names.fun_name = + match fun_id with + | Regular id -> (FunDeclId.Map.find id fun_decls).name + | Assumed aid -> Assumed.get_assumed_name aid + +(** Small utility: list the transitive parents of a region var group. + We don't do that in an efficient manner, but it doesn't matter. + + TODO: rename to "list_ancestors_..." + + This list *doesn't* include the current region. + *) +let rec list_parent_region_groups (sg : fun_sig) (gid : T.RegionGroupId.id) : + T.RegionGroupId.Set.t = + let rg = T.RegionGroupId.nth sg.regions_hierarchy gid in + let parents = + List.fold_left + (fun s gid -> + (* Compute the parents *) + let parents = list_parent_region_groups sg gid in + (* Parents U current region *) + let parents = T.RegionGroupId.Set.add gid parents in + (* Make the union with the accumulator *) + T.RegionGroupId.Set.union s parents) + T.RegionGroupId.Set.empty rg.parents + in + parents + +(** Small utility: same as {!list_parent_region_groups}, but returns an ordered list. *) +let list_ordered_parent_region_groups (sg : fun_sig) (gid : T.RegionGroupId.id) + : T.RegionGroupId.id list = + let pset = list_parent_region_groups sg gid in + let parents = + List.filter + (fun (rg : T.region_var_group) -> T.RegionGroupId.Set.mem rg.id pset) + sg.regions_hierarchy + in + let parents = List.map (fun (rg : T.region_var_group) -> rg.id) parents in + parents + +let fun_body_get_input_vars (fbody : fun_body) : var list = + let locals = List.tl fbody.locals in + Collections.List.prefix fbody.arg_count locals diff --git a/compiler/LlbcOfJson.ml b/compiler/LlbcOfJson.ml new file mode 100644 index 00000000..79c9b756 --- /dev/null +++ b/compiler/LlbcOfJson.ml @@ -0,0 +1,915 @@ +(** Functions to load LLBC ASTs from json. + + Initially, we used [ppx_derive_yojson] to automate this. + However, [ppx_derive_yojson] expects formatting to be slightly + different from what [serde_rs] generates (because it uses [Yojson.Safe.t] + and not [Yojson.Basic.t]). + + TODO: we should check all that the integer values are in the proper range + *) + +open Yojson.Basic +open Names +open OfJsonBasic +open Identifiers +open Meta +module T = Types +module V = Values +module S = Scalars +module E = Expressions +module A = LlbcAst +module TU = TypesUtils +module AU = LlbcAstUtils +module LocalFileId = IdGen () +module VirtualFileId = IdGen () + +(** The default logger *) +let log = Logging.llbc_of_json_logger + +(** A file identifier *) +type file_id = LocalId of LocalFileId.id | VirtualId of VirtualFileId.id +[@@deriving show, ord] + +module OrderedIdToFile : Collections.OrderedType with type t = file_id = struct + type t = file_id + + let compare fid0 fid1 = compare_file_id fid0 fid1 + + let to_string id = + match id with + | LocalId id -> "Local " ^ LocalFileId.to_string id + | VirtualId id -> "Virtual " ^ VirtualFileId.to_string id + + let pp_t fmt x = Format.pp_print_string fmt (to_string x) + let show_t x = to_string x +end + +module IdToFile = Collections.MakeMap (OrderedIdToFile) + +type id_to_file_map = file_name IdToFile.t + +let file_id_of_json (js : json) : (file_id, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc [ ("LocalId", id) ] -> + let* id = LocalFileId.id_of_json id in + Ok (LocalId id) + | `Assoc [ ("VirtualId", id) ] -> + let* id = VirtualFileId.id_of_json id in + Ok (VirtualId id) + | _ -> Error "") + +let file_name_of_json (js : json) : (file_name, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc [ ("Virtual", name) ] -> + let* name = string_of_json name in + Ok (Virtual name) + | `Assoc [ ("Local", name) ] -> + let* name = string_of_json name in + Ok (Local name) + | _ -> Error "") + +(** Deserialize a map from file id to file name. + + In the serialized LLBC, the files in the loc spans are refered to by their + ids, in order to save space. In a functional language like OCaml this is + not necessary: we thus replace the file ids by the file name themselves in + the AST. + The "id to file" map is thus only used in the deserialization process. + *) +let id_to_file_of_json (js : json) : (id_to_file_map, string) result = + combine_error_msgs js __FUNCTION__ + ((* The map is stored as a list of pairs (key, value): we deserialize + * this list then convert it to a map *) + let* key_values = + list_of_json (pair_of_json file_id_of_json file_name_of_json) js + in + Ok (IdToFile.of_list key_values)) + +let loc_of_json (js : json) : (loc, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc [ ("line", line); ("col", col) ] -> + let* line = int_of_json line in + let* col = int_of_json col in + Ok { line; col } + | _ -> Error "") + +let span_of_json (id_to_file : id_to_file_map) (js : json) : + (span, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc [ ("file_id", file_id); ("beg", beg_loc); ("end", end_loc) ] -> + let* file_id = file_id_of_json file_id in + let file = IdToFile.find file_id id_to_file in + let* beg_loc = loc_of_json beg_loc in + let* end_loc = loc_of_json end_loc in + Ok { file; beg_loc; end_loc } + | _ -> Error "") + +let meta_of_json (id_to_file : id_to_file_map) (js : json) : + (meta, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc [ ("span", span); ("generated_from_span", generated_from_span) ] -> + let* span = span_of_json id_to_file span in + let* generated_from_span = + option_of_json (span_of_json id_to_file) generated_from_span + in + Ok { span; generated_from_span } + | _ -> Error "") + +let path_elem_of_json (js : json) : (path_elem, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc [ ("Ident", name) ] -> + let* name = string_of_json name in + Ok (Ident name) + | `Assoc [ ("Disambiguator", d) ] -> + let* d = Disambiguator.id_of_json d in + Ok (Disambiguator d) + | _ -> Error "") + +let name_of_json (js : json) : (name, string) result = + combine_error_msgs js __FUNCTION__ (list_of_json path_elem_of_json js) + +let fun_name_of_json (js : json) : (fun_name, string) result = + combine_error_msgs js __FUNCTION__ (name_of_json js) + +let type_var_of_json (js : json) : (T.type_var, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc [ ("index", index); ("name", name) ] -> + let* index = T.TypeVarId.id_of_json index in + let* name = string_of_json name in + Ok { T.index; name } + | _ -> Error "") + +let region_var_of_json (js : json) : (T.region_var, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc [ ("index", index); ("name", name) ] -> + let* index = T.RegionVarId.id_of_json index in + let* name = string_option_of_json name in + Ok { T.index; name } + | _ -> Error "") + +let region_of_json (js : json) : (T.RegionVarId.id T.region, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `String "Static" -> Ok T.Static + | `Assoc [ ("Var", rid) ] -> + let* rid = T.RegionVarId.id_of_json rid in + Ok (T.Var rid) + | _ -> Error "") + +let erased_region_of_json (js : json) : (T.erased_region, string) result = + combine_error_msgs js __FUNCTION__ + (match js with `String "Erased" -> Ok T.Erased | _ -> Error "") + +let integer_type_of_json (js : json) : (T.integer_type, string) result = + match js with + | `String "Isize" -> Ok T.Isize + | `String "I8" -> Ok T.I8 + | `String "I16" -> Ok T.I16 + | `String "I32" -> Ok T.I32 + | `String "I64" -> Ok T.I64 + | `String "I128" -> Ok T.I128 + | `String "Usize" -> Ok T.Usize + | `String "U8" -> Ok T.U8 + | `String "U16" -> Ok T.U16 + | `String "U32" -> Ok T.U32 + | `String "U64" -> Ok T.U64 + | `String "U128" -> Ok T.U128 + | _ -> Error ("integer_type_of_json failed on: " ^ show js) + +let ref_kind_of_json (js : json) : (T.ref_kind, string) result = + match js with + | `String "Mut" -> Ok T.Mut + | `String "Shared" -> Ok T.Shared + | _ -> Error ("ref_kind_of_json failed on: " ^ show js) + +let assumed_ty_of_json (js : json) : (T.assumed_ty, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `String "Box" -> Ok T.Box + | `String "Vec" -> Ok T.Vec + | `String "Option" -> Ok T.Option + | _ -> Error "") + +let type_id_of_json (js : json) : (T.type_id, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc [ ("Adt", id) ] -> + let* id = T.TypeDeclId.id_of_json id in + Ok (T.AdtId id) + | `String "Tuple" -> Ok T.Tuple + | `Assoc [ ("Assumed", aty) ] -> + let* aty = assumed_ty_of_json aty in + Ok (T.Assumed aty) + | _ -> Error "") + +let rec ty_of_json (r_of_json : json -> ('r, string) result) (js : json) : + ('r T.ty, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc [ ("Adt", `List [ id; regions; types ]) ] -> + let* id = type_id_of_json id in + let* regions = list_of_json r_of_json regions in + let* types = list_of_json (ty_of_json r_of_json) types in + (* Sanity check *) + (match id with T.Tuple -> assert (List.length regions = 0) | _ -> ()); + Ok (T.Adt (id, regions, types)) + | `Assoc [ ("TypeVar", `List [ id ]) ] -> + let* id = T.TypeVarId.id_of_json id in + Ok (T.TypeVar id) + | `String "Bool" -> Ok Bool + | `String "Char" -> Ok Char + | `String "`Never" -> Ok Never + | `Assoc [ ("Integer", `List [ int_ty ]) ] -> + let* int_ty = integer_type_of_json int_ty in + Ok (T.Integer int_ty) + | `String "Str" -> Ok Str + | `Assoc [ ("Array", `List [ ty ]) ] -> + let* ty = ty_of_json r_of_json ty in + Ok (T.Array ty) + | `Assoc [ ("Slice", `List [ ty ]) ] -> + let* ty = ty_of_json r_of_json ty in + Ok (T.Slice ty) + | `Assoc [ ("Ref", `List [ region; ty; ref_kind ]) ] -> + let* region = r_of_json region in + let* ty = ty_of_json r_of_json ty in + let* ref_kind = ref_kind_of_json ref_kind in + Ok (T.Ref (region, ty, ref_kind)) + | _ -> Error "") + +let sty_of_json (js : json) : (T.sty, string) result = + combine_error_msgs js __FUNCTION__ (ty_of_json region_of_json js) + +let ety_of_json (js : json) : (T.ety, string) result = + combine_error_msgs js __FUNCTION__ (ty_of_json erased_region_of_json js) + +let field_of_json (id_to_file : id_to_file_map) (js : json) : + (T.field, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc [ ("meta", meta); ("name", name); ("ty", ty) ] -> + let* meta = meta_of_json id_to_file meta in + let* name = option_of_json string_of_json name in + let* ty = sty_of_json ty in + Ok { T.meta; field_name = name; field_ty = ty } + | _ -> Error "") + +let variant_of_json (id_to_file : id_to_file_map) (js : json) : + (T.variant, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc [ ("meta", meta); ("name", name); ("fields", fields) ] -> + let* meta = meta_of_json id_to_file meta in + let* name = string_of_json name in + let* fields = list_of_json (field_of_json id_to_file) fields in + Ok { T.meta; variant_name = name; fields } + | _ -> Error "") + +let type_decl_kind_of_json (id_to_file : id_to_file_map) (js : json) : + (T.type_decl_kind, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc [ ("Struct", fields) ] -> + let* fields = list_of_json (field_of_json id_to_file) fields in + Ok (T.Struct fields) + | `Assoc [ ("Enum", variants) ] -> + let* variants = list_of_json (variant_of_json id_to_file) variants in + Ok (T.Enum variants) + | `String "Opaque" -> Ok T.Opaque + | _ -> Error "") + +let region_var_group_of_json (js : json) : (T.region_var_group, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc [ ("id", id); ("regions", regions); ("parents", parents) ] -> + let* id = T.RegionGroupId.id_of_json id in + let* regions = list_of_json T.RegionVarId.id_of_json regions in + let* parents = list_of_json T.RegionGroupId.id_of_json parents in + Ok { T.id; regions; parents } + | _ -> Error "") + +let region_var_groups_of_json (js : json) : (T.region_var_groups, string) result + = + combine_error_msgs js __FUNCTION__ (list_of_json region_var_group_of_json js) + +let type_decl_of_json (id_to_file : id_to_file_map) (js : json) : + (T.type_decl, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc + [ + ("def_id", def_id); + ("meta", meta); + ("name", name); + ("region_params", region_params); + ("type_params", type_params); + ("regions_hierarchy", regions_hierarchy); + ("kind", kind); + ] -> + let* def_id = T.TypeDeclId.id_of_json def_id in + let* meta = meta_of_json id_to_file meta in + let* name = name_of_json name in + let* region_params = list_of_json region_var_of_json region_params in + let* type_params = list_of_json type_var_of_json type_params in + let* kind = type_decl_kind_of_json id_to_file kind in + let* regions_hierarchy = region_var_groups_of_json regions_hierarchy in + Ok + { + T.def_id; + meta; + name; + region_params; + type_params; + kind; + regions_hierarchy; + } + | _ -> Error "") + +let var_of_json (js : json) : (A.var, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc [ ("index", index); ("name", name); ("ty", ty) ] -> + let* index = V.VarId.id_of_json index in + let* name = string_option_of_json name in + let* var_ty = ety_of_json ty in + Ok { A.index; name; var_ty } + | _ -> Error "") + +let big_int_of_json (js : json) : (V.big_int, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Int i -> Ok (Z.of_int i) + | `String is -> Ok (Z.of_string is) + | _ -> Error "") + +(** Deserialize a {!V.scalar_value} from JSON and **check the ranges**. + + Note that in practice we also check that the values are in range + in the interpreter functions. Still, it doesn't cost much to be + a bit conservative. + *) +let scalar_value_of_json (js : json) : (V.scalar_value, string) result = + let res = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc [ ("Isize", `List [ bi ]) ] -> + let* bi = big_int_of_json bi in + Ok { V.value = bi; int_ty = Isize } + | `Assoc [ ("I8", `List [ bi ]) ] -> + let* bi = big_int_of_json bi in + Ok { V.value = bi; int_ty = I8 } + | `Assoc [ ("I16", `List [ bi ]) ] -> + let* bi = big_int_of_json bi in + Ok { V.value = bi; int_ty = I16 } + | `Assoc [ ("I32", `List [ bi ]) ] -> + let* bi = big_int_of_json bi in + Ok { V.value = bi; int_ty = I32 } + | `Assoc [ ("I64", `List [ bi ]) ] -> + let* bi = big_int_of_json bi in + Ok { V.value = bi; int_ty = I64 } + | `Assoc [ ("I128", `List [ bi ]) ] -> + let* bi = big_int_of_json bi in + Ok { V.value = bi; int_ty = I128 } + | `Assoc [ ("Usize", `List [ bi ]) ] -> + let* bi = big_int_of_json bi in + Ok { V.value = bi; int_ty = Usize } + | `Assoc [ ("U8", `List [ bi ]) ] -> + let* bi = big_int_of_json bi in + Ok { V.value = bi; int_ty = U8 } + | `Assoc [ ("U16", `List [ bi ]) ] -> + let* bi = big_int_of_json bi in + Ok { V.value = bi; int_ty = U16 } + | `Assoc [ ("U32", `List [ bi ]) ] -> + let* bi = big_int_of_json bi in + Ok { V.value = bi; int_ty = U32 } + | `Assoc [ ("U64", `List [ bi ]) ] -> + let* bi = big_int_of_json bi in + Ok { V.value = bi; int_ty = U64 } + | `Assoc [ ("U128", `List [ bi ]) ] -> + let* bi = big_int_of_json bi in + Ok { V.value = bi; int_ty = U128 } + | _ -> Error "") + in + match res with + | Error _ -> res + | Ok sv -> + if not (S.check_scalar_value_in_range sv) then ( + log#serror ("Scalar value not in range: " ^ V.show_scalar_value sv); + raise (Failure ("Scalar value not in range: " ^ V.show_scalar_value sv))); + res + +let field_proj_kind_of_json (js : json) : (E.field_proj_kind, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc [ ("ProjAdt", `List [ def_id; opt_variant_id ]) ] -> + let* def_id = T.TypeDeclId.id_of_json def_id in + let* opt_variant_id = + option_of_json T.VariantId.id_of_json opt_variant_id + in + Ok (E.ProjAdt (def_id, opt_variant_id)) + | `Assoc [ ("ProjTuple", i) ] -> + let* i = int_of_json i in + Ok (E.ProjTuple i) + | `Assoc [ ("ProjOption", variant_id) ] -> + let* variant_id = T.VariantId.id_of_json variant_id in + Ok (E.ProjOption variant_id) + | _ -> Error "") + +let projection_elem_of_json (js : json) : (E.projection_elem, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `String "Deref" -> Ok E.Deref + | `String "DerefBox" -> Ok E.DerefBox + | `Assoc [ ("Field", `List [ proj_kind; field_id ]) ] -> + let* proj_kind = field_proj_kind_of_json proj_kind in + let* field_id = T.FieldId.id_of_json field_id in + Ok (E.Field (proj_kind, field_id)) + | _ -> Error ("projection_elem_of_json failed on:" ^ show js)) + +let projection_of_json (js : json) : (E.projection, string) result = + combine_error_msgs js __FUNCTION__ (list_of_json projection_elem_of_json js) + +let place_of_json (js : json) : (E.place, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc [ ("var_id", var_id); ("projection", projection) ] -> + let* var_id = V.VarId.id_of_json var_id in + let* projection = projection_of_json projection in + Ok { E.var_id; projection } + | _ -> Error "") + +let borrow_kind_of_json (js : json) : (E.borrow_kind, string) result = + match js with + | `String "Shared" -> Ok E.Shared + | `String "Mut" -> Ok E.Mut + | `String "TwoPhaseMut" -> Ok E.TwoPhaseMut + | _ -> Error ("borrow_kind_of_json failed on:" ^ show js) + +let unop_of_json (js : json) : (E.unop, string) result = + match js with + | `String "Not" -> Ok E.Not + | `String "Neg" -> Ok E.Neg + | `Assoc [ ("Cast", `List [ src_ty; tgt_ty ]) ] -> + let* src_ty = integer_type_of_json src_ty in + let* tgt_ty = integer_type_of_json tgt_ty in + Ok (E.Cast (src_ty, tgt_ty)) + | _ -> Error ("unop_of_json failed on:" ^ show js) + +let binop_of_json (js : json) : (E.binop, string) result = + match js with + | `String "BitXor" -> Ok E.BitXor + | `String "BitAnd" -> Ok E.BitAnd + | `String "BitOr" -> Ok E.BitOr + | `String "Eq" -> Ok E.Eq + | `String "Lt" -> Ok E.Lt + | `String "Le" -> Ok E.Le + | `String "Ne" -> Ok E.Ne + | `String "Ge" -> Ok E.Ge + | `String "Gt" -> Ok E.Gt + | `String "Div" -> Ok E.Div + | `String "Rem" -> Ok E.Rem + | `String "Add" -> Ok E.Add + | `String "Sub" -> Ok E.Sub + | `String "Mul" -> Ok E.Mul + | `String "Shl" -> Ok E.Shl + | `String "Shr" -> Ok E.Shr + | _ -> Error ("binop_of_json failed on:" ^ show js) + +let constant_value_of_json (js : json) : (V.constant_value, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc [ ("Scalar", scalar_value) ] -> + let* scalar_value = scalar_value_of_json scalar_value in + Ok (V.Scalar scalar_value) + | `Assoc [ ("Bool", v) ] -> + let* v = bool_of_json v in + Ok (V.Bool v) + | `Assoc [ ("Char", v) ] -> + let* v = char_of_json v in + Ok (V.Char v) + | `Assoc [ ("String", v) ] -> + let* v = string_of_json v in + Ok (V.String v) + | _ -> Error "") + +let operand_of_json (js : json) : (E.operand, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc [ ("Copy", place) ] -> + let* place = place_of_json place in + Ok (E.Copy place) + | `Assoc [ ("Move", place) ] -> + let* place = place_of_json place in + Ok (E.Move place) + | `Assoc [ ("Const", `List [ ty; cv ]) ] -> + let* ty = ety_of_json ty in + let* cv = constant_value_of_json cv in + Ok (E.Constant (ty, cv)) + | _ -> Error "") + +let aggregate_kind_of_json (js : json) : (E.aggregate_kind, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `String "AggregatedTuple" -> Ok E.AggregatedTuple + | `Assoc [ ("AggregatedOption", `List [ variant_id; ty ]) ] -> + let* variant_id = T.VariantId.id_of_json variant_id in + let* ty = ety_of_json ty in + Ok (E.AggregatedOption (variant_id, ty)) + | `Assoc [ ("AggregatedAdt", `List [ id; opt_variant_id; regions; tys ]) ] + -> + let* id = T.TypeDeclId.id_of_json id in + let* opt_variant_id = + option_of_json T.VariantId.id_of_json opt_variant_id + in + let* regions = list_of_json erased_region_of_json regions in + let* tys = list_of_json ety_of_json tys in + Ok (E.AggregatedAdt (id, opt_variant_id, regions, tys)) + | _ -> Error "") + +let rvalue_of_json (js : json) : (E.rvalue, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc [ ("Use", op) ] -> + let* op = operand_of_json op in + Ok (E.Use op) + | `Assoc [ ("Ref", `List [ place; borrow_kind ]) ] -> + let* place = place_of_json place in + let* borrow_kind = borrow_kind_of_json borrow_kind in + Ok (E.Ref (place, borrow_kind)) + | `Assoc [ ("UnaryOp", `List [ unop; op ]) ] -> + let* unop = unop_of_json unop in + let* op = operand_of_json op in + Ok (E.UnaryOp (unop, op)) + | `Assoc [ ("BinaryOp", `List [ binop; op1; op2 ]) ] -> + let* binop = binop_of_json binop in + let* op1 = operand_of_json op1 in + let* op2 = operand_of_json op2 in + Ok (E.BinaryOp (binop, op1, op2)) + | `Assoc [ ("Discriminant", place) ] -> + let* place = place_of_json place in + Ok (E.Discriminant place) + | `Assoc [ ("Aggregate", `List [ aggregate_kind; ops ]) ] -> + let* aggregate_kind = aggregate_kind_of_json aggregate_kind in + let* ops = list_of_json operand_of_json ops in + Ok (E.Aggregate (aggregate_kind, ops)) + | _ -> Error "") + +let assumed_fun_id_of_json (js : json) : (A.assumed_fun_id, string) result = + match js with + | `String "Replace" -> Ok A.Replace + | `String "BoxNew" -> Ok A.BoxNew + | `String "BoxDeref" -> Ok A.BoxDeref + | `String "BoxDerefMut" -> Ok A.BoxDerefMut + | `String "BoxFree" -> Ok A.BoxFree + | `String "VecNew" -> Ok A.VecNew + | `String "VecPush" -> Ok A.VecPush + | `String "VecInsert" -> Ok A.VecInsert + | `String "VecLen" -> Ok A.VecLen + | `String "VecIndex" -> Ok A.VecIndex + | `String "VecIndexMut" -> Ok A.VecIndexMut + | _ -> Error ("assumed_fun_id_of_json failed on:" ^ show js) + +let fun_id_of_json (js : json) : (A.fun_id, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc [ ("Regular", id) ] -> + let* id = A.FunDeclId.id_of_json id in + Ok (A.Regular id) + | `Assoc [ ("Assumed", fid) ] -> + let* fid = assumed_fun_id_of_json fid in + Ok (A.Assumed fid) + | _ -> Error "") + +let assertion_of_json (js : json) : (A.assertion, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc [ ("cond", cond); ("expected", expected) ] -> + let* cond = operand_of_json cond in + let* expected = bool_of_json expected in + Ok { A.cond; expected } + | _ -> Error "") + +let fun_sig_of_json (js : json) : (A.fun_sig, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc + [ + ("region_params", region_params); + ("num_early_bound_regions", num_early_bound_regions); + ("regions_hierarchy", regions_hierarchy); + ("type_params", type_params); + ("inputs", inputs); + ("output", output); + ] -> + let* region_params = list_of_json region_var_of_json region_params in + let* num_early_bound_regions = int_of_json num_early_bound_regions in + let* regions_hierarchy = region_var_groups_of_json regions_hierarchy in + let* type_params = list_of_json type_var_of_json type_params in + let* inputs = list_of_json sty_of_json inputs in + let* output = sty_of_json output in + Ok + { + A.region_params; + num_early_bound_regions; + regions_hierarchy; + type_params; + inputs; + output; + } + | _ -> Error "") + +let call_of_json (js : json) : (A.call, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc + [ + ("func", func); + ("region_args", region_args); + ("type_args", type_args); + ("args", args); + ("dest", dest); + ] -> + let* func = fun_id_of_json func in + let* region_args = list_of_json erased_region_of_json region_args in + let* type_args = list_of_json ety_of_json type_args in + let* args = list_of_json operand_of_json args in + let* dest = place_of_json dest in + Ok { A.func; region_args; type_args; args; dest } + | _ -> Error "") + +let rec statement_of_json (id_to_file : id_to_file_map) (js : json) : + (A.statement, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc [ ("meta", meta); ("content", content) ] -> + let* meta = meta_of_json id_to_file meta in + let* content = raw_statement_of_json id_to_file content in + Ok { A.meta; content } + | _ -> Error "") + +and raw_statement_of_json (id_to_file : id_to_file_map) (js : json) : + (A.raw_statement, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc [ ("Assign", `List [ place; rvalue ]) ] -> + let* place = place_of_json place in + let* rvalue = rvalue_of_json rvalue in + Ok (A.Assign (place, rvalue)) + | `Assoc [ ("AssignGlobal", `List [ dst; global ]) ] -> + let* dst = V.VarId.id_of_json dst in + let* global = A.GlobalDeclId.id_of_json global in + Ok (A.AssignGlobal { dst; global }) + | `Assoc [ ("FakeRead", place) ] -> + let* place = place_of_json place in + Ok (A.FakeRead place) + | `Assoc [ ("SetDiscriminant", `List [ place; variant_id ]) ] -> + let* place = place_of_json place in + let* variant_id = T.VariantId.id_of_json variant_id in + Ok (A.SetDiscriminant (place, variant_id)) + | `Assoc [ ("Drop", place) ] -> + let* place = place_of_json place in + Ok (A.Drop place) + | `Assoc [ ("Assert", assertion) ] -> + let* assertion = assertion_of_json assertion in + Ok (A.Assert assertion) + | `Assoc [ ("Call", call) ] -> + let* call = call_of_json call in + Ok (A.Call call) + | `String "Panic" -> Ok A.Panic + | `String "Return" -> Ok A.Return + | `Assoc [ ("Break", i) ] -> + let* i = int_of_json i in + Ok (A.Break i) + | `Assoc [ ("Continue", i) ] -> + let* i = int_of_json i in + Ok (A.Continue i) + | `String "Nop" -> Ok A.Nop + | `Assoc [ ("Sequence", `List [ st1; st2 ]) ] -> + let* st1 = statement_of_json id_to_file st1 in + let* st2 = statement_of_json id_to_file st2 in + Ok (A.Sequence (st1, st2)) + | `Assoc [ ("Switch", `List [ op; tgt ]) ] -> + let* op = operand_of_json op in + let* tgt = switch_targets_of_json id_to_file tgt in + Ok (A.Switch (op, tgt)) + | `Assoc [ ("Loop", st) ] -> + let* st = statement_of_json id_to_file st in + Ok (A.Loop st) + | _ -> Error "") + +and switch_targets_of_json (id_to_file : id_to_file_map) (js : json) : + (A.switch_targets, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc [ ("If", `List [ st1; st2 ]) ] -> + let* st1 = statement_of_json id_to_file st1 in + let* st2 = statement_of_json id_to_file st2 in + Ok (A.If (st1, st2)) + | `Assoc [ ("SwitchInt", `List [ int_ty; tgts; otherwise ]) ] -> + let* int_ty = integer_type_of_json int_ty in + let* tgts = + list_of_json + (pair_of_json + (list_of_json scalar_value_of_json) + (statement_of_json id_to_file)) + tgts + in + let* otherwise = statement_of_json id_to_file otherwise in + Ok (A.SwitchInt (int_ty, tgts, otherwise)) + | _ -> Error "") + +let fun_body_of_json (id_to_file : id_to_file_map) (js : json) : + (A.fun_body, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc + [ + ("meta", meta); + ("arg_count", arg_count); + ("locals", locals); + ("body", body); + ] -> + let* meta = meta_of_json id_to_file meta in + let* arg_count = int_of_json arg_count in + let* locals = list_of_json var_of_json locals in + let* body = statement_of_json id_to_file body in + Ok { A.meta; arg_count; locals; body } + | _ -> Error "") + +let fun_decl_of_json (id_to_file : id_to_file_map) (js : json) : + (A.fun_decl, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc + [ + ("def_id", def_id); + ("meta", meta); + ("name", name); + ("signature", signature); + ("body", body); + ] -> + let* def_id = A.FunDeclId.id_of_json def_id in + let* meta = meta_of_json id_to_file meta in + let* name = fun_name_of_json name in + let* signature = fun_sig_of_json signature in + let* body = option_of_json (fun_body_of_json id_to_file) body in + Ok + { A.def_id; meta; name; signature; body; is_global_decl_body = false } + | _ -> Error "") + +(* Strict type for the number of function declarations (see {!global_to_fun_id} below) *) +type global_id_converter = { fun_count : int } [@@deriving show] + +(** Converts a global id to its corresponding function id. + To do so, it adds the global id to the number of function declarations : + We have the bijection [global_fun_id <=> global_id + fun_id_count]. +*) +let global_to_fun_id (conv : global_id_converter) (gid : A.GlobalDeclId.id) : + A.FunDeclId.id = + A.FunDeclId.of_int (A.GlobalDeclId.to_int gid + conv.fun_count) + +(* Converts a global declaration to a function declaration. + *) +let global_decl_of_json (id_to_file : id_to_file_map) (js : json) + (gid_conv : global_id_converter) : + (A.global_decl * A.fun_decl, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc + [ + ("def_id", def_id); + ("meta", meta); + ("name", name); + ("ty", ty); + ("body", body); + ] -> + let* global_id = A.GlobalDeclId.id_of_json def_id in + let fun_id = global_to_fun_id gid_conv global_id in + let* meta = meta_of_json id_to_file meta in + let* name = fun_name_of_json name in + let* ty = ety_of_json ty in + let* body = option_of_json (fun_body_of_json id_to_file) body in + let signature : A.fun_sig = + { + region_params = []; + num_early_bound_regions = 0; + regions_hierarchy = []; + type_params = []; + inputs = []; + output = TU.ety_no_regions_to_sty ty; + } + in + Ok + ( { A.def_id = global_id; meta; body_id = fun_id; name; ty }, + { + A.def_id = fun_id; + meta; + name; + signature; + body; + is_global_decl_body = true; + } ) + | _ -> Error "") + +let g_declaration_group_of_json (id_of_json : json -> ('id, string) result) + (js : json) : ('id Crates.g_declaration_group, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc [ ("NonRec", `List [ id ]) ] -> + let* id = id_of_json id in + Ok (Crates.NonRec id) + | `Assoc [ ("Rec", `List [ ids ]) ] -> + let* ids = list_of_json id_of_json ids in + Ok (Crates.Rec ids) + | _ -> Error "") + +let type_declaration_group_of_json (js : json) : + (Crates.type_declaration_group, string) result = + combine_error_msgs js __FUNCTION__ + (g_declaration_group_of_json T.TypeDeclId.id_of_json js) + +let fun_declaration_group_of_json (js : json) : + (Crates.fun_declaration_group, string) result = + combine_error_msgs js __FUNCTION__ + (g_declaration_group_of_json A.FunDeclId.id_of_json js) + +let global_declaration_group_of_json (js : json) : + (A.GlobalDeclId.id, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc [ ("NonRec", `List [ id ]) ] -> + let* id = A.GlobalDeclId.id_of_json id in + Ok id + | `Assoc [ ("Rec", `List [ _ ]) ] -> Error "got mutually dependent globals" + | _ -> Error "") + +let declaration_group_of_json (js : json) : + (Crates.declaration_group, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc [ ("Type", `List [ decl ]) ] -> + let* decl = type_declaration_group_of_json decl in + Ok (Crates.Type decl) + | `Assoc [ ("Fun", `List [ decl ]) ] -> + let* decl = fun_declaration_group_of_json decl in + Ok (Crates.Fun decl) + | `Assoc [ ("Global", `List [ decl ]) ] -> + let* id = global_declaration_group_of_json decl in + Ok (Crates.Global id) + | _ -> Error "") + +let length_of_json_list (js : json) : (int, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `List jsl -> Ok (List.length jsl) + | _ -> Error ("not a list: " ^ show js)) + +let llbc_crate_of_json (js : json) : (Crates.llbc_crate, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc + [ + ("name", name); + ("id_to_file", id_to_file); + ("declarations", declarations); + ("types", types); + ("functions", functions); + ("globals", globals); + ] -> + (* We first deserialize the declaration groups (which simply contain ids) + * and all the declarations *butù* the globals *) + let* name = string_of_json name in + let* id_to_file = id_to_file_of_json id_to_file in + let* declarations = + list_of_json declaration_group_of_json declarations + in + let* types = list_of_json (type_decl_of_json id_to_file) types in + let* functions = list_of_json (fun_decl_of_json id_to_file) functions in + (* When deserializing the globals, we split the global declarations + * between the globals themselves and their bodies, which are simply + * functions with no arguments. We add the global bodies to the list + * of function declarations: the (fresh) ids we use for those bodies + * are simply given by: [num_functions + global_id] *) + let gid_conv = { fun_count = List.length functions } in + let* globals = + list_of_json + (fun js -> global_decl_of_json id_to_file js gid_conv) + globals + in + let globals, global_bodies = List.split globals in + Ok + { + Crates.name; + declarations; + types; + functions = functions @ global_bodies; + globals; + } + | _ -> Error "") diff --git a/compiler/Logging.ml b/compiler/Logging.ml new file mode 100644 index 00000000..e83f25f8 --- /dev/null +++ b/compiler/Logging.ml @@ -0,0 +1,179 @@ +module H = Easy_logging.Handlers +module L = Easy_logging.Logging + +let _ = L.make_logger "MainLogger" Debug [ Cli Debug ] + +(** The main logger *) +let main_log = L.get_logger "MainLogger" + +(** Below, we create subgloggers for various submodules, so that we can precisely + toggle logging on/off, depending on which information we need *) + +(** Logger for LlbcOfJson *) +let llbc_of_json_logger = L.get_logger "MainLogger.LlbcOfJson" + +(** Logger for PrePasses *) +let pre_passes_log = L.get_logger "MainLogger.PrePasses" + +(** Logger for Translate *) +let translate_log = L.get_logger "MainLogger.Translate" + +(** Logger for PureUtils *) +let pure_utils_log = L.get_logger "MainLogger.PureUtils" + +(** Logger for SymbolicToPure *) +let symbolic_to_pure_log = L.get_logger "MainLogger.SymbolicToPure" + +(** Logger for PureMicroPasses *) +let pure_micro_passes_log = L.get_logger "MainLogger.PureMicroPasses" + +(** Logger for PureToExtract *) +let pure_to_extract_log = L.get_logger "MainLogger.PureToExtract" + +(** Logger for Interpreter *) +let interpreter_log = L.get_logger "MainLogger.Interpreter" + +(** Logger for InterpreterStatements *) +let statements_log = L.get_logger "MainLogger.Interpreter.Statements" + +(** Logger for InterpreterExpressions *) +let expressions_log = L.get_logger "MainLogger.Interpreter.Expressions" + +(** Logger for InterpreterPaths *) +let paths_log = L.get_logger "MainLogger.Interpreter.Paths" + +(** Logger for InterpreterExpansion *) +let expansion_log = L.get_logger "MainLogger.Interpreter.Expansion" + +(** Logger for InterpreterBorrows *) +let borrows_log = L.get_logger "MainLogger.Interpreter.Borrows" + +(** Logger for Invariants *) +let invariants_log = L.get_logger "MainLogger.Interpreter.Invariants" + +(** Terminal colors - TODO: comes from easy_logging (did not manage to reuse the module directly) *) +type color = + | Default + | Black + | Red + | Green + | Yellow + | Blue + | Magenta + | Cyan + | Gray + | White + | LRed + | LGreen + | LYellow + | LBlue + | LMagenta + | LCyan + | LGray + +(** Terminal styles - TODO: comes from easy_logging (did not manage to reuse the module directly) *) +type format = Bold | Underline | Invert | Fg of color | Bg of color + +(** TODO: comes from easy_logging (did not manage to reuse the module directly) *) +let to_fg_code c = + match c with + | Default -> 39 + | Black -> 30 + | Red -> 31 + | Green -> 32 + | Yellow -> 33 + | Blue -> 34 + | Magenta -> 35 + | Cyan -> 36 + | Gray -> 90 + | White -> 97 + | LRed -> 91 + | LGreen -> 92 + | LYellow -> 93 + | LBlue -> 94 + | LMagenta -> 95 + | LCyan -> 96 + | LGray -> 37 + +(** TODO: comes from easy_logging (did not manage to reuse the module directly) *) +let to_bg_code c = + match c with + | Default -> 49 + | Black -> 40 + | Red -> 41 + | Green -> 42 + | Yellow -> 43 + | Blue -> 44 + | Magenta -> 45 + | Cyan -> 46 + | Gray -> 100 + | White -> 107 + | LRed -> 101 + | LGreen -> 102 + | LYellow -> 103 + | LBlue -> 104 + | LMagenta -> 105 + | LCyan -> 106 + | LGray -> 47 + +(** TODO: comes from easy_logging (did not manage to reuse the module directly) *) +let style_to_codes s = + match s with + | Bold -> (1, 21) + | Underline -> (4, 24) + | Invert -> (7, 27) + | Fg c -> (to_fg_code c, to_fg_code Default) + | Bg c -> (to_bg_code c, to_bg_code Default) + +(** TODO: comes from easy_logging (did not manage to reuse the module directly) + I made a minor modifications, though. *) +let level_to_color (lvl : L.level) = + match lvl with + | L.Flash -> LMagenta + | Error -> LRed + | Warning -> LYellow + | Info -> LGreen + | Trace -> Cyan + | Debug -> LBlue + | NoLevel -> Default + +(** [format styles str] formats [str] to the given [styles] - + TODO: comes from {{: http://ocamlverse.net/content/documentation_guidelines.html}[easy_logging]} + (did not manage to reuse the module directly) +*) +let rec format styles str = + match styles with + | (_ as s) :: styles' -> + let set, reset = style_to_codes s in + Printf.sprintf "\027[%dm%s\027[%dm" set (format styles' str) reset + | [] -> str + +(** TODO: comes from {{: http://ocamlverse.net/content/documentation_guidelines.html}[easy_logging]} + (did not manage to reuse the module directly) *) +let format_tags (tags : string list) = + match tags with + | [] -> "" + | _ -> + let elems_str = String.concat " | " tags in + "[" ^ elems_str ^ "] " + +(* Change the formatters *) +let main_logger_handler = + (* TODO: comes from easy_logging *) + let formatter (item : L.log_item) : string = + let item_level_fmt = + format [ Fg (level_to_color item.level) ] (L.show_level item.level) + and item_msg_fmt = + match item.level with + | Flash -> format [ Fg Black; Bg LMagenta ] item.msg + | _ -> item.msg + in + + Format.pp_set_max_indent Format.str_formatter 200; + Format.sprintf "@[[%-15s] %s%s@]" item_level_fmt (format_tags item.tags) + item_msg_fmt + in + (* There should be exactly one handler *) + let handlers = main_log#get_handlers in + List.iter (fun h -> H.set_formatter h formatter) handlers; + match handlers with [ handler ] -> handler | _ -> failwith "Unexpected" diff --git a/compiler/Meta.ml b/compiler/Meta.ml new file mode 100644 index 00000000..f0e4ca04 --- /dev/null +++ b/compiler/Meta.ml @@ -0,0 +1,44 @@ +(** Meta data like code spans *) + +(** A line location *) +type loc = { + line : int; (** The (1-based) line number. *) + col : int; (** The (0-based) column offset. *) +} +[@@deriving show] + +type file_name = + | Virtual of string (** A remapped path (namely paths into stdlib) *) + | Local of string + (** A local path (a file coming from the current crate for instance) *) +[@@deriving show] + +(** Span data *) +type span = { file : file_name; beg_loc : loc; end_loc : loc } [@@deriving show] + +type meta = { + span : span; + (** The source code span. + + If this meta information is for a statement/terminator coming from a macro + expansion/inlining/etc., this span is (in case of macros) for the macro + before expansion (i.e., the location the code where the user wrote the call + to the macro). + + Ex: + {[ + // Below, we consider the spans for the statements inside `test` + + // the statement we consider, which gets inlined in `test` + VV + macro_rules! macro { ... st ... } // `generated_from_span` refers to this location + + fn test() { + macro!(); // <-- `span` refers to this location + } + ]} + *) + generated_from_span : span option; + (** Where the code actually comes from, in case of macro expansion/inlining/etc. *) +} +[@@deriving show] diff --git a/compiler/Names.ml b/compiler/Names.ml new file mode 100644 index 00000000..a27db161 --- /dev/null +++ b/compiler/Names.ml @@ -0,0 +1,80 @@ +open Identifiers +module Disambiguator = IdGen () + +(** See the comments for [Name] *) +type path_elem = Ident of string | Disambiguator of Disambiguator.id +[@@deriving show, ord] + +(** A name such as: [std::collections::vector] (which would be represented as + [[Ident "std"; Ident "collections"; Ident "vector"]]) + + + A name really is a list of strings. However, we sometimes need to + introduce unique indices to disambiguate. This mostly happens because + of "impl" blocks in Rust: + {[ + impl<T> List<T> { + ... + } + ]} + + A type in Rust can have several "impl" blocks, and those blocks can + contain items with similar names. For this reason, we need to disambiguate + them with unique indices. Rustc calls those "disambiguators". In rustc, this + gives names like this: + - [betree_main::betree::NodeIdCounter{impl#0}::new] + - note that impl blocks can be nested, and macros sometimes generate + weird names (which require disambiguation): + [betree_main::betree_utils::_#1::{impl#0}::deserialize::{impl#0}] + + Finally, the paths used by rustc are a lot more precise and explicit than + those we expose in LLBC: for instance, every identifier belongs to a specific + namespace (value namespace, type namespace, etc.), and is coupled with a + disambiguator. + + On our side, we want to stay high-level and simple: we use string identifiers + as much as possible, insert disambiguators only when necessary (whenever + we find an "impl" block, typically) and check that the disambiguator is useless + in the other situations (i.e., the disambiguator is always equal to 0). + + Moreover, the items are uniquely disambiguated by their (integer) ids + ([TypeDeclId.id], etc.), and when extracting the code we have to deal with + name clashes anyway. Still, we might want to be more precise in the future. + + Also note that the first path element in the name is always the crate name. + *) +type name = path_elem list [@@deriving show, ord] + +let to_name (ls : string list) : name = List.map (fun s -> Ident s) ls + +type module_name = name [@@deriving show, ord] +type type_name = name [@@deriving show, ord] +type fun_name = name [@@deriving show, ord] +type global_name = name [@@deriving show, ord] + +(** Filter the disambiguators equal to 0 in a name *) +let filter_disambiguators_zero (n : name) : name = + let pred (pe : path_elem) : bool = + match pe with Ident _ -> true | Disambiguator d -> d <> Disambiguator.zero + in + List.filter pred n + +(** Filter the disambiguators in a name *) +let filter_disambiguators (n : name) : name = + let pred (pe : path_elem) : bool = + match pe with Ident _ -> true | Disambiguator _ -> false + in + List.filter pred n + +let as_ident (pe : path_elem) : string = + match pe with + | Ident s -> s + | Disambiguator _ -> raise (Failure "Improper variant") + +let path_elem_to_string (pe : path_elem) : string = + match pe with + | Ident s -> s + | Disambiguator d -> "{" ^ Disambiguator.to_string d ^ "}" + +let name_to_string (name : name) : string = + String.concat "::" (List.map path_elem_to_string name) diff --git a/compiler/OfJsonBasic.ml b/compiler/OfJsonBasic.ml new file mode 100644 index 00000000..07daf03d --- /dev/null +++ b/compiler/OfJsonBasic.ml @@ -0,0 +1,75 @@ +(** This module defines various basic utilities for json deserialization. + + *) + +open Yojson.Basic + +type json = t + +let ( let* ) o f = match o with Error e -> Error e | Ok x -> f x + +let combine_error_msgs js msg res : ('a, string) result = + match res with + | Ok x -> Ok x + | Error e -> Error ("[" ^ msg ^ "]" ^ " failed on: " ^ show js ^ "\n\n" ^ e) + +let bool_of_json (js : json) : (bool, string) result = + match js with + | `Bool b -> Ok b + | _ -> Error ("bool_of_json: not a bool: " ^ show js) + +let int_of_json (js : json) : (int, string) result = + match js with + | `Int i -> Ok i + | _ -> Error ("int_of_json: not an int: " ^ show js) + +let char_of_json (js : json) : (char, string) result = + match js with + | `String c -> + if String.length c = 1 then Ok c.[0] + else Error ("char_of_json: stricly more than one character in: " ^ show js) + | _ -> Error ("char_of_json: not a char: " ^ show js) + +let rec of_json_list (a_of_json : json -> ('a, string) result) (jsl : json list) + : ('a list, string) result = + match jsl with + | [] -> Ok [] + | x :: jsl' -> + let* x = a_of_json x in + let* jsl' = of_json_list a_of_json jsl' in + Ok (x :: jsl') + +let pair_of_json (a_of_json : json -> ('a, string) result) + (b_of_json : json -> ('b, string) result) (js : json) : + ('a * 'b, string) result = + match js with + | `List [ a; b ] -> + let* a = a_of_json a in + let* b = b_of_json b in + Ok (a, b) + | _ -> Error ("pair_of_json failed on: " ^ show js) + +let list_of_json (a_of_json : json -> ('a, string) result) (js : json) : + ('a list, string) result = + combine_error_msgs js "list_of_json" + (match js with + | `List jsl -> of_json_list a_of_json jsl + | _ -> Error ("not a list: " ^ show js)) + +let string_of_json (js : json) : (string, string) result = + match js with + | `String str -> Ok str + | _ -> Error ("string_of_json: not a string: " ^ show js) + +let option_of_json (a_of_json : json -> ('a, string) result) (js : json) : + ('a option, string) result = + combine_error_msgs js "option_of_json" + (match js with + | `Null -> Ok None + | _ -> + let* x = a_of_json js in + Ok (Some x)) + +let string_option_of_json (js : json) : (string option, string) result = + combine_error_msgs js "string_option_of_json" + (option_of_json string_of_json js) diff --git a/compiler/PrePasses.ml b/compiler/PrePasses.ml new file mode 100644 index 00000000..a09ae476 --- /dev/null +++ b/compiler/PrePasses.ml @@ -0,0 +1,54 @@ +(** This files contains passes we apply on the AST *before* calling the + (concrete/symbolic) interpreter on it + *) + +module T = Types +module V = Values +module E = Expressions +module C = Contexts +module A = LlbcAst +module L = Logging + +let log = L.pre_passes_log + +(** Rustc inserts a lot of drops before the assignments. + We consider those drops are part of the assignment, and splitting the + drop and the assignment is problematic for us because it can introduce + [⊥] under borrows. For instance, we encountered situations like the + following one: + + {[ + drop( *x ); // Illegal! Inserts a ⊥ under a borrow + *x = move ...; + ]} + + TODO: this is not necessary anymore + *) +let filter_drop_assigns (f : A.fun_decl) : A.fun_decl = + (* The visitor *) + let obj = + object (self) + inherit [_] A.map_statement as super + + method! visit_Sequence env st1 st2 = + match (st1.content, st2.content) with + | Drop p1, Assign (p2, _) -> + if p1 = p2 then (self#visit_statement env st2).content + else super#visit_Sequence env st1 st2 + | Drop p1, Sequence ({ content = Assign (p2, _); meta = _ }, _) -> + if p1 = p2 then (self#visit_statement env st2).content + else super#visit_Sequence env st1 st2 + | _ -> super#visit_Sequence env st1 st2 + end + in + (* Map *) + let body = + match f.body with + | Some body -> Some { body with body = obj#visit_statement () body.body } + | None -> None + in + { f with body } + +let apply_passes (m : Crates.llbc_crate) : Crates.llbc_crate = + let functions = List.map filter_drop_assigns m.functions in + { m with functions } diff --git a/compiler/Print.ml b/compiler/Print.ml new file mode 100644 index 00000000..8f52b291 --- /dev/null +++ b/compiler/Print.ml @@ -0,0 +1,1283 @@ +open Names +module T = Types +module TU = TypesUtils +module V = Values +module VU = ValuesUtils +module E = Expressions +module A = LlbcAst +module C = Contexts + +let option_to_string (to_string : 'a -> string) (x : 'a option) : string = + match x with Some x -> "Some (" ^ to_string x ^ ")" | None -> "None" + +let name_to_string (name : name) : string = Names.name_to_string name +let fun_name_to_string (name : fun_name) : string = name_to_string name +let global_name_to_string (name : global_name) : string = name_to_string name + +(** Pretty-printing for types *) +module Types = struct + let type_var_to_string (tv : T.type_var) : string = tv.name + + let region_var_to_string (rv : T.region_var) : string = + match rv.name with + | Some name -> name + | None -> T.RegionVarId.to_string rv.index + + let region_var_id_to_string (rid : T.RegionVarId.id) : string = + "rv@" ^ T.RegionVarId.to_string rid + + let region_id_to_string (rid : T.RegionId.id) : string = + "r@" ^ T.RegionId.to_string rid + + let region_to_string (rid_to_string : 'rid -> string) (r : 'rid T.region) : + string = + match r with Static -> "'static" | Var rid -> rid_to_string rid + + let erased_region_to_string (_ : T.erased_region) : string = "'_" + + let ref_kind_to_string (rk : T.ref_kind) : string = + match rk with Mut -> "Mut" | Shared -> "Shared" + + let assumed_ty_to_string (_ : T.assumed_ty) : string = "Box" + + type 'r type_formatter = { + r_to_string : 'r -> string; + type_var_id_to_string : T.TypeVarId.id -> string; + type_decl_id_to_string : T.TypeDeclId.id -> string; + } + + type stype_formatter = T.RegionVarId.id T.region type_formatter + type rtype_formatter = T.RegionId.id T.region type_formatter + type etype_formatter = T.erased_region type_formatter + + let integer_type_to_string = function + | T.Isize -> "isize" + | T.I8 -> "i8" + | T.I16 -> "i16" + | T.I32 -> "i32" + | T.I64 -> "i64" + | T.I128 -> "i128" + | T.Usize -> "usize" + | T.U8 -> "u8" + | T.U16 -> "u16" + | T.U32 -> "u32" + | T.U64 -> "u64" + | T.U128 -> "u128" + + let type_id_to_string (fmt : 'r type_formatter) (id : T.type_id) : string = + match id with + | T.AdtId id -> fmt.type_decl_id_to_string id + | T.Tuple -> "" + | T.Assumed aty -> ( + match aty with + | Box -> "alloc::boxed::Box" + | Vec -> "alloc::vec::Vec" + | Option -> "core::option::Option") + + let rec ty_to_string (fmt : 'r type_formatter) (ty : 'r T.ty) : string = + match ty with + | T.Adt (id, regions, tys) -> + let is_tuple = match id with T.Tuple -> true | _ -> false in + let params = params_to_string fmt is_tuple regions tys in + type_id_to_string fmt id ^ params + | T.TypeVar tv -> fmt.type_var_id_to_string tv + | T.Bool -> "bool" + | T.Char -> "char" + | T.Never -> "⊥" + | T.Integer int_ty -> integer_type_to_string int_ty + | T.Str -> "str" + | T.Array aty -> "[" ^ ty_to_string fmt aty ^ "; ?]" + | T.Slice sty -> "[" ^ ty_to_string fmt sty ^ "]" + | T.Ref (r, rty, ref_kind) -> ( + match ref_kind with + | T.Mut -> + "&" ^ fmt.r_to_string r ^ " mut (" ^ ty_to_string fmt rty ^ ")" + | T.Shared -> + "&" ^ fmt.r_to_string r ^ " (" ^ ty_to_string fmt rty ^ ")") + + and params_to_string (fmt : 'r type_formatter) (is_tuple : bool) + (regions : 'r list) (types : 'r T.ty list) : string = + let regions = List.map fmt.r_to_string regions in + let types = List.map (ty_to_string fmt) types in + let params = String.concat ", " (List.append regions types) in + if is_tuple then "(" ^ params ^ ")" + else if List.length regions + List.length types > 0 then "<" ^ params ^ ">" + else "" + + let sty_to_string (fmt : stype_formatter) (ty : T.sty) : string = + ty_to_string fmt ty + + let rty_to_string (fmt : rtype_formatter) (ty : T.rty) : string = + ty_to_string fmt ty + + let ety_to_string (fmt : etype_formatter) (ty : T.ety) : string = + ty_to_string fmt ty + + let field_to_string fmt (f : T.field) : string = + match f.field_name with + | Some field_name -> field_name ^ " : " ^ ty_to_string fmt f.field_ty + | None -> ty_to_string fmt f.field_ty + + let variant_to_string fmt (v : T.variant) : string = + v.variant_name ^ "(" + ^ String.concat ", " (List.map (field_to_string fmt) v.fields) + ^ ")" + + let type_decl_to_string (type_decl_id_to_string : T.TypeDeclId.id -> string) + (def : T.type_decl) : string = + let regions = def.region_params in + let types = def.type_params in + let rid_to_string rid = + match List.find_opt (fun rv -> rv.T.index = rid) regions with + | Some rv -> region_var_to_string rv + | None -> failwith "Unreachable" + in + let r_to_string = region_to_string rid_to_string in + let type_var_id_to_string id = + match List.find_opt (fun tv -> tv.T.index = id) types with + | Some tv -> type_var_to_string tv + | None -> failwith "Unreachable" + in + let fmt = { r_to_string; type_var_id_to_string; type_decl_id_to_string } in + let name = name_to_string def.name in + let params = + if List.length regions + List.length types > 0 then + let regions = List.map region_var_to_string regions in + let types = List.map type_var_to_string types in + let params = String.concat ", " (List.append regions types) in + "<" ^ params ^ ">" + else "" + in + match def.kind with + | T.Struct fields -> + if List.length fields > 0 then + let fields = + String.concat "," + (List.map (fun f -> "\n " ^ field_to_string fmt f) fields) + in + "struct " ^ name ^ params ^ "{" ^ fields ^ "}" + else "struct " ^ name ^ params ^ "{}" + | T.Enum variants -> + let variants = + List.map (fun v -> "| " ^ variant_to_string fmt v) variants + in + let variants = String.concat "\n" variants in + "enum " ^ name ^ params ^ " =\n" ^ variants + | T.Opaque -> "opaque type " ^ name ^ params +end + +module PT = Types (* local module *) + +(** Pretty-printing for values *) +module Values = struct + type value_formatter = { + rvar_to_string : T.RegionVarId.id -> string; + r_to_string : T.RegionId.id -> string; + type_var_id_to_string : T.TypeVarId.id -> string; + type_decl_id_to_string : T.TypeDeclId.id -> string; + adt_variant_to_string : T.TypeDeclId.id -> T.VariantId.id -> string; + var_id_to_string : V.VarId.id -> string; + adt_field_names : + T.TypeDeclId.id -> T.VariantId.id option -> string list option; + } + + let value_to_etype_formatter (fmt : value_formatter) : PT.etype_formatter = + { + PT.r_to_string = PT.erased_region_to_string; + PT.type_var_id_to_string = fmt.type_var_id_to_string; + PT.type_decl_id_to_string = fmt.type_decl_id_to_string; + } + + let value_to_rtype_formatter (fmt : value_formatter) : PT.rtype_formatter = + { + PT.r_to_string = PT.region_to_string fmt.r_to_string; + PT.type_var_id_to_string = fmt.type_var_id_to_string; + PT.type_decl_id_to_string = fmt.type_decl_id_to_string; + } + + let value_to_stype_formatter (fmt : value_formatter) : PT.stype_formatter = + { + PT.r_to_string = PT.region_to_string fmt.rvar_to_string; + PT.type_var_id_to_string = fmt.type_var_id_to_string; + PT.type_decl_id_to_string = fmt.type_decl_id_to_string; + } + + let var_id_to_string (id : V.VarId.id) : string = + "var@" ^ V.VarId.to_string id + + let big_int_to_string (bi : V.big_int) : string = Z.to_string bi + + let scalar_value_to_string (sv : V.scalar_value) : string = + big_int_to_string sv.value ^ ": " ^ PT.integer_type_to_string sv.int_ty + + let constant_value_to_string (cv : V.constant_value) : string = + match cv with + | Scalar sv -> scalar_value_to_string sv + | Bool b -> Bool.to_string b + | Char c -> String.make 1 c + | String s -> s + + let symbolic_value_id_to_string (id : V.SymbolicValueId.id) : string = + "s@" ^ V.SymbolicValueId.to_string id + + let symbolic_value_to_string (fmt : PT.rtype_formatter) + (sv : V.symbolic_value) : string = + symbolic_value_id_to_string sv.sv_id ^ " : " ^ PT.rty_to_string fmt sv.sv_ty + + let symbolic_value_proj_to_string (fmt : value_formatter) + (sv : V.symbolic_value) (rty : T.rty) : string = + symbolic_value_id_to_string sv.sv_id + ^ " : " + ^ PT.ty_to_string (value_to_rtype_formatter fmt) sv.sv_ty + ^ " <: " + ^ PT.ty_to_string (value_to_rtype_formatter fmt) rty + + (* TODO: it may be a good idea to try to factorize this function with + * typed_avalue_to_string. At some point we had done it, because [typed_value] + * and [typed_avalue] were instances of the same general type [g_typed_value], + * but then we removed this general type because it proved to be a bad idea. *) + let rec typed_value_to_string (fmt : value_formatter) (v : V.typed_value) : + string = + let ty_fmt : PT.etype_formatter = value_to_etype_formatter fmt in + match v.value with + | Concrete cv -> constant_value_to_string cv + | Adt av -> ( + let field_values = + List.map (typed_value_to_string fmt) av.field_values + in + match v.ty with + | T.Adt (T.Tuple, _, _) -> + (* Tuple *) + "(" ^ String.concat ", " field_values ^ ")" + | T.Adt (T.AdtId def_id, _, _) -> + (* "Regular" ADT *) + let adt_ident = + match av.variant_id with + | Some vid -> fmt.adt_variant_to_string def_id vid + | None -> fmt.type_decl_id_to_string def_id + in + if List.length field_values > 0 then + match fmt.adt_field_names def_id av.V.variant_id with + | None -> + let field_values = String.concat ", " field_values in + adt_ident ^ " (" ^ field_values ^ ")" + | Some field_names -> + let field_values = List.combine field_names field_values in + let field_values = + List.map + (fun (field, value) -> field ^ " = " ^ value ^ ";") + field_values + in + let field_values = String.concat " " field_values in + adt_ident ^ " { " ^ field_values ^ " }" + else adt_ident + | T.Adt (T.Assumed aty, _, _) -> ( + (* Assumed type *) + match (aty, field_values) with + | Box, [ bv ] -> "@Box(" ^ bv ^ ")" + | Option, _ -> + if av.variant_id = Some T.option_some_id then + "@Option::Some(" + ^ Collections.List.to_cons_nil field_values + ^ ")" + else if av.variant_id = Some T.option_none_id then ( + assert (field_values = []); + "@Option::None") + else failwith "Unreachable" + | Vec, _ -> "@Vec[" ^ String.concat ", " field_values ^ "]" + | _ -> failwith "Inconsistent value") + | _ -> failwith "Inconsistent typed value") + | Bottom -> "⊥ : " ^ PT.ty_to_string ty_fmt v.ty + | Borrow bc -> borrow_content_to_string fmt bc + | Loan lc -> loan_content_to_string fmt lc + | Symbolic s -> symbolic_value_to_string (value_to_rtype_formatter fmt) s + + and borrow_content_to_string (fmt : value_formatter) (bc : V.borrow_content) : + string = + match bc with + | SharedBorrow (_, bid) -> "⌊shared@" ^ V.BorrowId.to_string bid ^ "⌋" + | MutBorrow (bid, tv) -> + "&mut@" ^ V.BorrowId.to_string bid ^ " (" + ^ typed_value_to_string fmt tv + ^ ")" + | InactivatedMutBorrow (_, bid) -> + "⌊inactivated_mut@" ^ V.BorrowId.to_string bid ^ "⌋" + + and loan_content_to_string (fmt : value_formatter) (lc : V.loan_content) : + string = + match lc with + | SharedLoan (loans, v) -> + let loans = V.BorrowId.Set.to_string None loans in + "@shared_loan(" ^ loans ^ ", " ^ typed_value_to_string fmt v ^ ")" + | MutLoan bid -> "⌊mut@" ^ V.BorrowId.to_string bid ^ "⌋" + + let abstract_shared_borrow_to_string (fmt : value_formatter) + (abs : V.abstract_shared_borrow) : string = + match abs with + | AsbBorrow bid -> V.BorrowId.to_string bid + | AsbProjReborrows (sv, rty) -> + "{" ^ symbolic_value_proj_to_string fmt sv rty ^ "}" + + let abstract_shared_borrows_to_string (fmt : value_formatter) + (abs : V.abstract_shared_borrows) : string = + "{" + ^ String.concat "," (List.map (abstract_shared_borrow_to_string fmt) abs) + ^ "}" + + let rec aproj_to_string (fmt : value_formatter) (pv : V.aproj) : string = + match pv with + | AProjLoans (sv, given_back) -> + let given_back = + if given_back = [] then "" + else + let given_back = List.map snd given_back in + let given_back = List.map (aproj_to_string fmt) given_back in + " (" ^ String.concat "," given_back ^ ") " + in + "⌊" + ^ symbolic_value_to_string (value_to_rtype_formatter fmt) sv + ^ given_back ^ "⌋" + | AProjBorrows (sv, rty) -> + "(" ^ symbolic_value_proj_to_string fmt sv rty ^ ")" + | AEndedProjLoans (_, given_back) -> + if given_back = [] then "_" + else + let given_back = List.map snd given_back in + let given_back = List.map (aproj_to_string fmt) given_back in + "ended_aproj_loans (" ^ String.concat "," given_back ^ ")" + | AEndedProjBorrows _mv -> "_" + | AIgnoredProjBorrows -> "_" + + let rec typed_avalue_to_string (fmt : value_formatter) (v : V.typed_avalue) : + string = + let ty_fmt : PT.rtype_formatter = value_to_rtype_formatter fmt in + match v.value with + | AConcrete cv -> constant_value_to_string cv + | AAdt av -> ( + let field_values = + List.map (typed_avalue_to_string fmt) av.field_values + in + match v.ty with + | T.Adt (T.Tuple, _, _) -> + (* Tuple *) + "(" ^ String.concat ", " field_values ^ ")" + | T.Adt (T.AdtId def_id, _, _) -> + (* "Regular" ADT *) + let adt_ident = + match av.variant_id with + | Some vid -> fmt.adt_variant_to_string def_id vid + | None -> fmt.type_decl_id_to_string def_id + in + if List.length field_values > 0 then + match fmt.adt_field_names def_id av.V.variant_id with + | None -> + let field_values = String.concat ", " field_values in + adt_ident ^ " (" ^ field_values ^ ")" + | Some field_names -> + let field_values = List.combine field_names field_values in + let field_values = + List.map + (fun (field, value) -> field ^ " = " ^ value ^ ";") + field_values + in + let field_values = String.concat " " field_values in + adt_ident ^ " { " ^ field_values ^ " }" + else adt_ident + | T.Adt (T.Assumed aty, _, _) -> ( + (* Assumed type *) + match (aty, field_values) with + | Box, [ bv ] -> "@Box(" ^ bv ^ ")" + | _ -> failwith "Inconsistent value") + | _ -> failwith "Inconsistent typed value") + | ABottom -> "⊥ : " ^ PT.ty_to_string ty_fmt v.ty + | ABorrow bc -> aborrow_content_to_string fmt bc + | ALoan lc -> aloan_content_to_string fmt lc + | ASymbolic s -> aproj_to_string fmt s + | AIgnored -> "_" + + and aloan_content_to_string (fmt : value_formatter) (lc : V.aloan_content) : + string = + match lc with + | AMutLoan (bid, av) -> + "⌊mut@" ^ V.BorrowId.to_string bid ^ ", " + ^ typed_avalue_to_string fmt av + ^ "⌋" + | ASharedLoan (loans, v, av) -> + let loans = V.BorrowId.Set.to_string None loans in + "@shared_loan(" ^ loans ^ ", " + ^ typed_value_to_string fmt v + ^ ", " + ^ typed_avalue_to_string fmt av + ^ ")" + | AEndedMutLoan ml -> + "@ended_mut_loan{" + ^ typed_avalue_to_string fmt ml.child + ^ "; " + ^ typed_avalue_to_string fmt ml.given_back + ^ " }" + | AEndedSharedLoan (v, av) -> + "@ended_shared_loan(" + ^ typed_value_to_string fmt v + ^ ", " + ^ typed_avalue_to_string fmt av + ^ ")" + | AIgnoredMutLoan (bid, av) -> + "@ignored_mut_loan(" ^ V.BorrowId.to_string bid ^ ", " + ^ typed_avalue_to_string fmt av + ^ ")" + | AEndedIgnoredMutLoan ml -> + "@ended_ignored_mut_loan{ " + ^ typed_avalue_to_string fmt ml.child + ^ "; " + ^ typed_avalue_to_string fmt ml.given_back + ^ "}" + | AIgnoredSharedLoan sl -> + "@ignored_shared_loan(" ^ typed_avalue_to_string fmt sl ^ ")" + + and aborrow_content_to_string (fmt : value_formatter) (bc : V.aborrow_content) + : string = + match bc with + | AMutBorrow (_, bid, av) -> + "&mut@" ^ V.BorrowId.to_string bid ^ " (" + ^ typed_avalue_to_string fmt av + ^ ")" + | ASharedBorrow bid -> "⌊shared@" ^ V.BorrowId.to_string bid ^ "⌋" + | AIgnoredMutBorrow (opt_bid, av) -> + "@ignored_mut_borrow(" + ^ option_to_string V.BorrowId.to_string opt_bid + ^ ", " + ^ typed_avalue_to_string fmt av + ^ ")" + | AEndedMutBorrow (_mv, child) -> + "@ended_mut_borrow(" ^ typed_avalue_to_string fmt child ^ ")" + | AEndedIgnoredMutBorrow + { child; given_back_loans_proj; given_back_meta = _ } -> + "@ended_ignored_mut_borrow{ " + ^ typed_avalue_to_string fmt child + ^ "; " + ^ typed_avalue_to_string fmt given_back_loans_proj + ^ ")" + | AEndedSharedBorrow -> "@ended_shared_borrow" + | AProjSharedBorrow sb -> + "@ignored_shared_borrow(" + ^ abstract_shared_borrows_to_string fmt sb + ^ ")" + + let abs_to_string (fmt : value_formatter) (indent : string) + (indent_incr : string) (abs : V.abs) : string = + let indent2 = indent ^ indent_incr in + let avs = + List.map (fun av -> indent2 ^ typed_avalue_to_string fmt av) abs.avalues + in + let avs = String.concat ",\n" avs in + indent ^ "abs@" + ^ V.AbstractionId.to_string abs.abs_id + ^ "{parents=" + ^ V.AbstractionId.Set.to_string None abs.parents + ^ "}" ^ "{regions=" + ^ T.RegionId.Set.to_string None abs.regions + ^ "}" ^ " {\n" ^ avs ^ "\n" ^ indent ^ "}" +end + +module PV = Values (* local module *) + +(** Pretty-printing for contexts *) +module Contexts = struct + let binder_to_string (bv : C.binder) : string = + match bv.name with + | None -> PV.var_id_to_string bv.index + | Some name -> name + + let env_elem_to_string (fmt : PV.value_formatter) (indent : string) + (indent_incr : string) (ev : C.env_elem) : string = + match ev with + | Var (var, tv) -> + let bv = + match var with Some var -> binder_to_string var | None -> "_" + in + indent ^ bv ^ " -> " ^ PV.typed_value_to_string fmt tv ^ " ;" + | Abs abs -> PV.abs_to_string fmt indent indent_incr abs + | Frame -> failwith "Can't print a Frame element" + + let opt_env_elem_to_string (fmt : PV.value_formatter) (indent : string) + (indent_incr : string) (ev : C.env_elem option) : string = + match ev with + | None -> indent ^ "..." + | Some ev -> env_elem_to_string fmt indent indent_incr ev + + (** Filters "dummy" bindings from an environment, to gain space and clarity/ + See [env_to_string]. *) + let filter_env (env : C.env) : C.env_elem option list = + (* We filter: + * - non-dummy bindings which point to ⊥ + * - dummy bindings which don't contain loans nor borrows + * Note that the first case can sometimes be confusing: we may try to improve + * it... + *) + let filter_elem (ev : C.env_elem) : C.env_elem option = + match ev with + | Var (Some _, tv) -> + (* Not a dummy binding: check if the value is ⊥ *) + if VU.is_bottom tv.value then None else Some ev + | Var (None, tv) -> + (* Dummy binding: check if the value contains borrows or loans *) + if VU.borrows_in_value tv || VU.loans_in_value tv then Some ev + else None + | _ -> Some ev + in + let env = List.map filter_elem env in + (* We collapse groups of filtered values - so that we can print one + * single "..." for a whole group of filtered values *) + let rec group_filtered (env : C.env_elem option list) : + C.env_elem option list = + match env with + | [] -> [] + | None :: None :: env -> group_filtered (None :: env) + | x :: env -> x :: group_filtered env + in + group_filtered env + + (** Environments can have a lot of dummy or uninitialized values: [filter] + allows to filter them when printing, replacing groups of such bindings with + "..." to gain space and clarity. + *) + let env_to_string (filter : bool) (fmt : PV.value_formatter) (env : C.env) : + string = + let env = + if filter then filter_env env else List.map (fun ev -> Some ev) env + in + "{\n" + ^ String.concat "\n" + (List.map (fun ev -> opt_env_elem_to_string fmt " " " " ev) env) + ^ "\n}" + + type ctx_formatter = PV.value_formatter + + let ctx_to_etype_formatter (fmt : ctx_formatter) : PT.etype_formatter = + PV.value_to_etype_formatter fmt + + let ctx_to_rtype_formatter (fmt : ctx_formatter) : PT.rtype_formatter = + PV.value_to_rtype_formatter fmt + + let type_ctx_to_adt_variant_to_string_fun + (ctx : T.type_decl T.TypeDeclId.Map.t) : + T.TypeDeclId.id -> T.VariantId.id -> string = + fun def_id variant_id -> + let def = T.TypeDeclId.Map.find def_id ctx in + match def.kind with + | Struct _ | Opaque -> failwith "Unreachable" + | Enum variants -> + let variant = T.VariantId.nth variants variant_id in + name_to_string def.name ^ "::" ^ variant.variant_name + + let type_ctx_to_adt_field_names_fun (ctx : T.type_decl T.TypeDeclId.Map.t) : + T.TypeDeclId.id -> T.VariantId.id option -> string list option = + fun def_id opt_variant_id -> + let def = T.TypeDeclId.Map.find def_id ctx in + let fields = TU.type_decl_get_fields def opt_variant_id in + (* There are two cases: either all the fields have names, or none of them + * has names *) + let has_names = + List.exists (fun f -> Option.is_some f.T.field_name) fields + in + if has_names then + let fields = List.map (fun f -> Option.get f.T.field_name) fields in + Some fields + else None + + let eval_ctx_to_ctx_formatter (ctx : C.eval_ctx) : ctx_formatter = + (* We shouldn't use rvar_to_string *) + let rvar_to_string _r = failwith "Unexpected use of rvar_to_string" in + let r_to_string r = PT.region_id_to_string r in + + let type_var_id_to_string vid = + let v = C.lookup_type_var ctx vid in + v.name + in + let type_decl_id_to_string def_id = + let def = C.ctx_lookup_type_decl ctx def_id in + name_to_string def.name + in + let adt_variant_to_string = + type_ctx_to_adt_variant_to_string_fun ctx.type_context.type_decls + in + let var_id_to_string vid = + let bv = C.ctx_lookup_binder ctx vid in + binder_to_string bv + in + let adt_field_names = + type_ctx_to_adt_field_names_fun ctx.type_context.type_decls + in + { + rvar_to_string; + r_to_string; + type_var_id_to_string; + type_decl_id_to_string; + adt_variant_to_string; + var_id_to_string; + adt_field_names; + } + + (** Split an [env] at every occurrence of [Frame], eliminating those elements. + Also reorders the frames and the values in the frames according to the + following order: + * frames: from the current frame to the first pushed (oldest frame) + * values: from the first pushed (oldest) to the last pushed + *) + let split_env_according_to_frames (env : C.env) : C.env list = + let rec split_aux (frames : C.env list) (curr_frame : C.env) (env : C.env) = + match env with + | [] -> + if List.length curr_frame > 0 then curr_frame :: frames else frames + | Frame :: env' -> split_aux (curr_frame :: frames) [] env' + | ev :: env' -> split_aux frames (ev :: curr_frame) env' + in + let frames = split_aux [] [] env in + frames + + let eval_ctx_to_string (ctx : C.eval_ctx) : string = + let fmt = eval_ctx_to_ctx_formatter ctx in + let ended_regions = T.RegionId.Set.to_string None ctx.ended_regions in + let frames = split_env_according_to_frames ctx.env in + let num_frames = List.length frames in + let frames = + List.mapi + (fun i f -> + let num_bindings = ref 0 in + let num_dummies = ref 0 in + let num_abs = ref 0 in + List.iter + (fun ev -> + match ev with + | C.Var (None, _) -> num_dummies := !num_abs + 1 + | C.Var (Some _, _) -> num_bindings := !num_bindings + 1 + | C.Abs _ -> num_abs := !num_abs + 1 + | _ -> raise (Failure "Unreachable")) + f; + "\n# Frame " ^ string_of_int i ^ ":" ^ "\n- locals: " + ^ string_of_int !num_bindings + ^ "\n- dummy bindings: " ^ string_of_int !num_dummies + ^ "\n- abstractions: " ^ string_of_int !num_abs ^ "\n" + ^ env_to_string true fmt f ^ "\n") + frames + in + "# Ended regions: " ^ ended_regions ^ "\n" ^ "# " ^ string_of_int num_frames + ^ " frame(s)\n" ^ String.concat "" frames +end + +module PC = Contexts (* local module *) + +(** Pretty-printing for contexts (generic functions) *) +module LlbcAst = struct + let var_to_string (var : A.var) : string = + match var.name with + | None -> V.VarId.to_string var.index + | Some name -> name + + type ast_formatter = { + rvar_to_string : T.RegionVarId.id -> string; + r_to_string : T.RegionId.id -> string; + type_var_id_to_string : T.TypeVarId.id -> string; + type_decl_id_to_string : T.TypeDeclId.id -> string; + adt_variant_to_string : T.TypeDeclId.id -> T.VariantId.id -> string; + adt_field_to_string : + T.TypeDeclId.id -> T.VariantId.id option -> T.FieldId.id -> string option; + var_id_to_string : V.VarId.id -> string; + adt_field_names : + T.TypeDeclId.id -> T.VariantId.id option -> string list option; + fun_decl_id_to_string : A.FunDeclId.id -> string; + global_decl_id_to_string : A.GlobalDeclId.id -> string; + } + + let ast_to_ctx_formatter (fmt : ast_formatter) : PC.ctx_formatter = + { + PV.rvar_to_string = fmt.rvar_to_string; + PV.r_to_string = fmt.r_to_string; + PV.type_var_id_to_string = fmt.type_var_id_to_string; + PV.type_decl_id_to_string = fmt.type_decl_id_to_string; + PV.adt_variant_to_string = fmt.adt_variant_to_string; + PV.var_id_to_string = fmt.var_id_to_string; + PV.adt_field_names = fmt.adt_field_names; + } + + let ast_to_value_formatter (fmt : ast_formatter) : PV.value_formatter = + ast_to_ctx_formatter fmt + + let ast_to_etype_formatter (fmt : ast_formatter) : PT.etype_formatter = + { + PT.r_to_string = PT.erased_region_to_string; + PT.type_var_id_to_string = fmt.type_var_id_to_string; + PT.type_decl_id_to_string = fmt.type_decl_id_to_string; + } + + let ast_to_rtype_formatter (fmt : ast_formatter) : PT.rtype_formatter = + { + PT.r_to_string = PT.region_to_string fmt.r_to_string; + PT.type_var_id_to_string = fmt.type_var_id_to_string; + PT.type_decl_id_to_string = fmt.type_decl_id_to_string; + } + + let ast_to_stype_formatter (fmt : ast_formatter) : PT.stype_formatter = + { + PT.r_to_string = PT.region_to_string fmt.rvar_to_string; + PT.type_var_id_to_string = fmt.type_var_id_to_string; + PT.type_decl_id_to_string = fmt.type_decl_id_to_string; + } + + let type_ctx_to_adt_field_to_string_fun (ctx : T.type_decl T.TypeDeclId.Map.t) + : + T.TypeDeclId.id -> T.VariantId.id option -> T.FieldId.id -> string option + = + fun def_id opt_variant_id field_id -> + let def = T.TypeDeclId.Map.find def_id ctx in + let fields = TU.type_decl_get_fields def opt_variant_id in + let field = T.FieldId.nth fields field_id in + field.T.field_name + + let eval_ctx_to_ast_formatter (ctx : C.eval_ctx) : ast_formatter = + let ctx_fmt = PC.eval_ctx_to_ctx_formatter ctx in + let adt_field_to_string = + type_ctx_to_adt_field_to_string_fun ctx.type_context.type_decls + in + let fun_decl_id_to_string def_id = + let def = C.ctx_lookup_fun_decl ctx def_id in + fun_name_to_string def.name + in + let global_decl_id_to_string def_id = + let def = C.ctx_lookup_global_decl ctx def_id in + global_name_to_string def.name + in + { + rvar_to_string = ctx_fmt.PV.rvar_to_string; + r_to_string = ctx_fmt.PV.r_to_string; + type_var_id_to_string = ctx_fmt.PV.type_var_id_to_string; + type_decl_id_to_string = ctx_fmt.PV.type_decl_id_to_string; + adt_variant_to_string = ctx_fmt.PV.adt_variant_to_string; + var_id_to_string = ctx_fmt.PV.var_id_to_string; + adt_field_names = ctx_fmt.PV.adt_field_names; + adt_field_to_string; + fun_decl_id_to_string; + global_decl_id_to_string; + } + + let fun_decl_to_ast_formatter (type_decls : T.type_decl T.TypeDeclId.Map.t) + (fun_decls : A.fun_decl A.FunDeclId.Map.t) + (global_decls : A.global_decl A.GlobalDeclId.Map.t) (fdef : A.fun_decl) : + ast_formatter = + let rvar_to_string r = + let rvar = T.RegionVarId.nth fdef.signature.region_params r in + PT.region_var_to_string rvar + in + let r_to_string r = PT.region_id_to_string r in + + let type_var_id_to_string vid = + let var = T.TypeVarId.nth fdef.signature.type_params vid in + PT.type_var_to_string var + in + let type_decl_id_to_string def_id = + let def = T.TypeDeclId.Map.find def_id type_decls in + name_to_string def.name + in + let adt_variant_to_string = + PC.type_ctx_to_adt_variant_to_string_fun type_decls + in + let var_id_to_string vid = + let var = V.VarId.nth (Option.get fdef.body).locals vid in + var_to_string var + in + let adt_field_names = PC.type_ctx_to_adt_field_names_fun type_decls in + let adt_field_to_string = type_ctx_to_adt_field_to_string_fun type_decls in + let fun_decl_id_to_string def_id = + let def = A.FunDeclId.Map.find def_id fun_decls in + fun_name_to_string def.name + in + let global_decl_id_to_string def_id = + let def = A.GlobalDeclId.Map.find def_id global_decls in + global_name_to_string def.name + in + { + rvar_to_string; + r_to_string; + type_var_id_to_string; + type_decl_id_to_string; + adt_variant_to_string; + var_id_to_string; + adt_field_names; + adt_field_to_string; + fun_decl_id_to_string; + global_decl_id_to_string; + } + + let rec projection_to_string (fmt : ast_formatter) (inside : string) + (p : E.projection) : string = + match p with + | [] -> inside + | pe :: p' -> ( + let s = projection_to_string fmt inside p' in + match pe with + | E.Deref -> "*(" ^ s ^ ")" + | E.DerefBox -> "deref_box(" ^ s ^ ")" + | E.Field (E.ProjOption variant_id, fid) -> + assert (variant_id = T.option_some_id); + assert (fid = T.FieldId.zero); + "(" ^ s ^ " as Option::Some)." ^ T.FieldId.to_string fid + | E.Field (E.ProjTuple _, fid) -> + "(" ^ s ^ ")." ^ T.FieldId.to_string fid + | E.Field (E.ProjAdt (adt_id, opt_variant_id), fid) -> ( + let field_name = + match fmt.adt_field_to_string adt_id opt_variant_id fid with + | Some field_name -> field_name + | None -> T.FieldId.to_string fid + in + match opt_variant_id with + | None -> "(" ^ s ^ ")." ^ field_name + | Some variant_id -> + let variant_name = + fmt.adt_variant_to_string adt_id variant_id + in + "(" ^ s ^ " as " ^ variant_name ^ ")." ^ field_name)) + + let place_to_string (fmt : ast_formatter) (p : E.place) : string = + let var = fmt.var_id_to_string p.E.var_id in + projection_to_string fmt var p.E.projection + + let unop_to_string (unop : E.unop) : string = + match unop with + | E.Not -> "¬" + | E.Neg -> "-" + | E.Cast (src, tgt) -> + "cast<" + ^ PT.integer_type_to_string src + ^ "," + ^ PT.integer_type_to_string tgt + ^ ">" + + let binop_to_string (binop : E.binop) : string = + match binop with + | E.BitXor -> "^" + | E.BitAnd -> "&" + | E.BitOr -> "|" + | E.Eq -> "==" + | E.Lt -> "<" + | E.Le -> "<=" + | E.Ne -> "!=" + | E.Ge -> ">=" + | E.Gt -> ">" + | E.Div -> "/" + | E.Rem -> "%" + | E.Add -> "+" + | E.Sub -> "-" + | E.Mul -> "*" + | E.Shl -> "<<" + | E.Shr -> ">>" + + let operand_to_string (fmt : ast_formatter) (op : E.operand) : string = + match op with + | E.Copy p -> "copy " ^ place_to_string fmt p + | E.Move p -> "move " ^ place_to_string fmt p + | E.Constant (ty, cv) -> + "(" + ^ PV.constant_value_to_string cv + ^ " : " + ^ PT.ety_to_string (ast_to_etype_formatter fmt) ty + ^ ")" + + let rvalue_to_string (fmt : ast_formatter) (rv : E.rvalue) : string = + match rv with + | E.Use op -> operand_to_string fmt op + | E.Ref (p, bk) -> ( + let p = place_to_string fmt p in + match bk with + | E.Shared -> "&" ^ p + | E.Mut -> "&mut " ^ p + | E.TwoPhaseMut -> "&two-phase " ^ p) + | E.UnaryOp (unop, op) -> + unop_to_string unop ^ " " ^ operand_to_string fmt op + | E.BinaryOp (binop, op1, op2) -> + operand_to_string fmt op1 ^ " " ^ binop_to_string binop ^ " " + ^ operand_to_string fmt op2 + | E.Discriminant p -> "discriminant(" ^ place_to_string fmt p ^ ")" + | E.Aggregate (akind, ops) -> ( + let ops = List.map (operand_to_string fmt) ops in + match akind with + | E.AggregatedTuple -> "(" ^ String.concat ", " ops ^ ")" + | E.AggregatedOption (variant_id, _ty) -> + if variant_id == T.option_none_id then ( + assert (ops == []); + "@Option::None") + else if variant_id == T.option_some_id then ( + assert (List.length ops == 1); + let op = List.hd ops in + "@Option::Some(" ^ op ^ ")") + else raise (Failure "Unreachable") + | E.AggregatedAdt (def_id, opt_variant_id, _regions, _types) -> + let adt_name = fmt.type_decl_id_to_string def_id in + let variant_name = + match opt_variant_id with + | None -> adt_name + | Some variant_id -> + adt_name ^ "::" ^ fmt.adt_variant_to_string def_id variant_id + in + let fields = + match fmt.adt_field_names def_id opt_variant_id with + | None -> "(" ^ String.concat ", " ops ^ ")" + | Some field_names -> + let fields = List.combine field_names ops in + let fields = + List.map + (fun (field, value) -> field ^ " = " ^ value ^ ";") + fields + in + let fields = String.concat " " fields in + "{ " ^ fields ^ " }" + in + variant_name ^ " " ^ fields) + + let rec statement_to_string (fmt : ast_formatter) (indent : string) + (indent_incr : string) (st : A.statement) : string = + raw_statement_to_string fmt indent indent_incr st.content + + and raw_statement_to_string (fmt : ast_formatter) (indent : string) + (indent_incr : string) (st : A.raw_statement) : string = + match st with + | A.Assign (p, rv) -> + indent ^ place_to_string fmt p ^ " := " ^ rvalue_to_string fmt rv + | A.AssignGlobal { dst; global } -> + indent ^ fmt.var_id_to_string dst ^ " := global " + ^ fmt.global_decl_id_to_string global + | A.FakeRead p -> indent ^ "fake_read " ^ place_to_string fmt p + | A.SetDiscriminant (p, variant_id) -> + (* TODO: improve this to lookup the variant name by using the def id *) + indent ^ "set_discriminant(" ^ place_to_string fmt p ^ ", " + ^ T.VariantId.to_string variant_id + ^ ")" + | A.Drop p -> indent ^ "drop " ^ place_to_string fmt p + | A.Assert a -> + let cond = operand_to_string fmt a.A.cond in + if a.A.expected then indent ^ "assert(" ^ cond ^ ")" + else indent ^ "assert(¬" ^ cond ^ ")" + | A.Call call -> + let ty_fmt = ast_to_etype_formatter fmt in + let t_params = + if List.length call.A.type_args > 0 then + "<" + ^ String.concat "," + (List.map (PT.ty_to_string ty_fmt) call.A.type_args) + ^ ">" + else "" + in + let args = List.map (operand_to_string fmt) call.A.args in + let args = "(" ^ String.concat ", " args ^ ")" in + let name_args = + match call.A.func with + | A.Regular fid -> fmt.fun_decl_id_to_string fid ^ t_params + | A.Assumed fid -> ( + match fid with + | A.Replace -> "core::mem::replace" ^ t_params + | A.BoxNew -> "alloc::boxed::Box" ^ t_params ^ "::new" + | A.BoxDeref -> + "core::ops::deref::Deref<Box" ^ t_params ^ ">::deref" + | A.BoxDerefMut -> + "core::ops::deref::DerefMut" ^ t_params ^ "::deref_mut" + | A.BoxFree -> "alloc::alloc::box_free" ^ t_params + | A.VecNew -> "alloc::vec::Vec" ^ t_params ^ "::new" + | A.VecPush -> "alloc::vec::Vec" ^ t_params ^ "::push" + | A.VecInsert -> "alloc::vec::Vec" ^ t_params ^ "::insert" + | A.VecLen -> "alloc::vec::Vec" ^ t_params ^ "::len" + | A.VecIndex -> + "core::ops::index::Index<alloc::vec::Vec" ^ t_params + ^ ">::index" + | A.VecIndexMut -> + "core::ops::index::IndexMut<alloc::vec::Vec" ^ t_params + ^ ">::index_mut") + in + let dest = place_to_string fmt call.A.dest in + indent ^ dest ^ " := move " ^ name_args ^ args + | A.Panic -> indent ^ "panic" + | A.Return -> indent ^ "return" + | A.Break i -> indent ^ "break " ^ string_of_int i + | A.Continue i -> indent ^ "continue " ^ string_of_int i + | A.Nop -> indent ^ "nop" + | A.Sequence (st1, st2) -> + statement_to_string fmt indent indent_incr st1 + ^ ";\n" + ^ statement_to_string fmt indent indent_incr st2 + | A.Switch (op, tgts) -> ( + let op = operand_to_string fmt op in + match tgts with + | A.If (true_st, false_st) -> + let inner_indent = indent ^ indent_incr in + let inner_to_string = + statement_to_string fmt inner_indent indent_incr + in + let true_st = inner_to_string true_st in + let false_st = inner_to_string false_st in + indent ^ "if (" ^ op ^ ") {\n" ^ true_st ^ "\n" ^ indent ^ "}\n" + ^ indent ^ "else {\n" ^ false_st ^ "\n" ^ indent ^ "}" + | A.SwitchInt (_ty, branches, otherwise) -> + let indent1 = indent ^ indent_incr in + let indent2 = indent1 ^ indent_incr in + let inner_to_string2 = + statement_to_string fmt indent2 indent_incr + in + let branches = + List.map + (fun (svl, be) -> + let svl = + List.map (fun sv -> "| " ^ PV.scalar_value_to_string sv) svl + in + let svl = String.concat " " svl in + indent1 ^ svl ^ " => {\n" ^ inner_to_string2 be ^ "\n" + ^ indent1 ^ "}") + branches + in + let branches = String.concat "\n" branches in + let branches = + branches ^ "\n" ^ indent1 ^ "_ => {\n" + ^ inner_to_string2 otherwise ^ "\n" ^ indent1 ^ "}" + in + indent ^ "switch (" ^ op ^ ") {\n" ^ branches ^ "\n" ^ indent ^ "}") + | A.Loop loop_st -> + indent ^ "loop {\n" + ^ statement_to_string fmt (indent ^ indent_incr) indent_incr loop_st + ^ "\n" ^ indent ^ "}" + + let var_to_string (v : A.var) : string = + match v.name with None -> PV.var_id_to_string v.index | Some name -> name + + let fun_decl_to_string (fmt : ast_formatter) (indent : string) + (indent_incr : string) (def : A.fun_decl) : string = + let sty_fmt = ast_to_stype_formatter fmt in + let sty_to_string = PT.sty_to_string sty_fmt in + let ety_fmt = ast_to_etype_formatter fmt in + let ety_to_string = PT.ety_to_string ety_fmt in + let sg = def.signature in + + (* Function name *) + let name = fun_name_to_string def.A.name in + + (* Region/type parameters *) + let regions = sg.region_params in + let types = sg.type_params in + let params = + if List.length regions + List.length types = 0 then "" + else + let regions = List.map PT.region_var_to_string regions in + let types = List.map PT.type_var_to_string types in + "<" ^ String.concat "," (List.append regions types) ^ ">" + in + + (* Return type *) + let ret_ty = sg.output in + let ret_ty = + if TU.ty_is_unit ret_ty then "" else " -> " ^ sty_to_string ret_ty + in + + (* We print the declaration differently if it is opaque (no body) or transparent + * (we have access to a body) *) + match def.body with + | None -> + (* Arguments *) + let input_tys = sg.inputs in + let args = List.map sty_to_string input_tys in + let args = String.concat ", " args in + + (* Put everything together *) + indent ^ "opaque fn " ^ name ^ params ^ "(" ^ args ^ ")" ^ ret_ty + | Some body -> + (* Arguments *) + let inputs = List.tl body.locals in + let inputs, _aux_locals = + Collections.List.split_at inputs body.arg_count + in + let args = List.combine inputs sg.inputs in + let args = + List.map + (fun (var, rty) -> var_to_string var ^ " : " ^ sty_to_string rty) + args + in + let args = String.concat ", " args in + + (* All the locals (with erased regions) *) + let locals = + List.map + (fun var -> + indent ^ indent_incr ^ var_to_string var ^ " : " + ^ ety_to_string var.var_ty ^ ";") + body.locals + in + let locals = String.concat "\n" locals in + + (* Body *) + let body = + statement_to_string fmt (indent ^ indent_incr) indent_incr body.body + in + + (* Put everything together *) + indent ^ "fn " ^ name ^ params ^ "(" ^ args ^ ")" ^ ret_ty ^ " {\n" + ^ locals ^ "\n\n" ^ body ^ "\n" ^ indent ^ "}" +end + +module PA = LlbcAst (* local module *) + +(** Pretty-printing for ASTs (functions based on a definition context) *) +module Module = struct + (** This function pretty-prints a type definition by using a definition + context *) + let type_decl_to_string (type_context : T.type_decl T.TypeDeclId.Map.t) + (def : T.type_decl) : string = + let type_decl_id_to_string (id : T.TypeDeclId.id) : string = + let def = T.TypeDeclId.Map.find id type_context in + name_to_string def.name + in + PT.type_decl_to_string type_decl_id_to_string def + + (** Generate an [ast_formatter] by using a definition context in combination + with the variables local to a function's definition *) + let def_ctx_to_ast_formatter (type_context : T.type_decl T.TypeDeclId.Map.t) + (fun_context : A.fun_decl A.FunDeclId.Map.t) + (global_context : A.global_decl A.GlobalDeclId.Map.t) (def : A.fun_decl) : + PA.ast_formatter = + let rvar_to_string vid = + let var = T.RegionVarId.nth def.signature.region_params vid in + PT.region_var_to_string var + in + let r_to_string vid = + (* TODO: we might want something more informative *) + PT.region_id_to_string vid + in + let type_var_id_to_string vid = + let var = T.TypeVarId.nth def.signature.type_params vid in + PT.type_var_to_string var + in + let type_decl_id_to_string def_id = + let def = T.TypeDeclId.Map.find def_id type_context in + name_to_string def.name + in + let fun_decl_id_to_string def_id = + let def = A.FunDeclId.Map.find def_id fun_context in + fun_name_to_string def.name + in + let global_decl_id_to_string def_id = + let def = A.GlobalDeclId.Map.find def_id global_context in + global_name_to_string def.name + in + let var_id_to_string vid = + let var = V.VarId.nth (Option.get def.body).locals vid in + PA.var_to_string var + in + let adt_variant_to_string = + PC.type_ctx_to_adt_variant_to_string_fun type_context + in + let adt_field_to_string = + PA.type_ctx_to_adt_field_to_string_fun type_context + in + let adt_field_names = PC.type_ctx_to_adt_field_names_fun type_context in + { + rvar_to_string; + r_to_string; + type_var_id_to_string; + type_decl_id_to_string; + adt_variant_to_string; + adt_field_to_string; + var_id_to_string; + adt_field_names; + fun_decl_id_to_string; + global_decl_id_to_string; + } + + (** This function pretty-prints a function definition by using a definition + context *) + let fun_decl_to_string (type_context : T.type_decl T.TypeDeclId.Map.t) + (fun_context : A.fun_decl A.FunDeclId.Map.t) + (global_context : A.global_decl A.GlobalDeclId.Map.t) (def : A.fun_decl) : + string = + let fmt = + def_ctx_to_ast_formatter type_context fun_context global_context def + in + PA.fun_decl_to_string fmt "" " " def + + let module_to_string (m : Crates.llbc_crate) : string = + let types_defs_map, funs_defs_map, globals_defs_map = + Crates.compute_defs_maps m + in + + (* The types *) + let type_decls = + List.map (type_decl_to_string types_defs_map) m.Crates.types + in + + (* The functions *) + let fun_decls = + List.map + (fun_decl_to_string types_defs_map funs_defs_map globals_defs_map) + m.Crates.functions + in + + (* Put everything together *) + let all_defs = List.append type_decls fun_decls in + String.concat "\n\n" all_defs +end + +(** Pretty-printing for LLBC ASTs (functions based on an evaluation context) *) +module EvalCtxLlbcAst = struct + let ety_to_string (ctx : C.eval_ctx) (t : T.ety) : string = + let fmt = PC.eval_ctx_to_ctx_formatter ctx in + let fmt = PC.ctx_to_etype_formatter fmt in + PT.ety_to_string fmt t + + let rty_to_string (ctx : C.eval_ctx) (t : T.rty) : string = + let fmt = PC.eval_ctx_to_ctx_formatter ctx in + let fmt = PC.ctx_to_rtype_formatter fmt in + PT.rty_to_string fmt t + + let borrow_content_to_string (ctx : C.eval_ctx) (bc : V.borrow_content) : + string = + let fmt = PC.eval_ctx_to_ctx_formatter ctx in + PV.borrow_content_to_string fmt bc + + let loan_content_to_string (ctx : C.eval_ctx) (lc : V.loan_content) : string = + let fmt = PC.eval_ctx_to_ctx_formatter ctx in + PV.loan_content_to_string fmt lc + + let aborrow_content_to_string (ctx : C.eval_ctx) (bc : V.aborrow_content) : + string = + let fmt = PC.eval_ctx_to_ctx_formatter ctx in + PV.aborrow_content_to_string fmt bc + + let aloan_content_to_string (ctx : C.eval_ctx) (lc : V.aloan_content) : string + = + let fmt = PC.eval_ctx_to_ctx_formatter ctx in + PV.aloan_content_to_string fmt lc + + let aproj_to_string (ctx : C.eval_ctx) (p : V.aproj) : string = + let fmt = PC.eval_ctx_to_ctx_formatter ctx in + PV.aproj_to_string fmt p + + let symbolic_value_to_string (ctx : C.eval_ctx) (sv : V.symbolic_value) : + string = + let fmt = PC.eval_ctx_to_ctx_formatter ctx in + let fmt = PC.ctx_to_rtype_formatter fmt in + PV.symbolic_value_to_string fmt sv + + let typed_value_to_string (ctx : C.eval_ctx) (v : V.typed_value) : string = + let fmt = PC.eval_ctx_to_ctx_formatter ctx in + PV.typed_value_to_string fmt v + + let typed_avalue_to_string (ctx : C.eval_ctx) (v : V.typed_avalue) : string = + let fmt = PC.eval_ctx_to_ctx_formatter ctx in + PV.typed_avalue_to_string fmt v + + let place_to_string (ctx : C.eval_ctx) (op : E.place) : string = + let fmt = PA.eval_ctx_to_ast_formatter ctx in + PA.place_to_string fmt op + + let operand_to_string (ctx : C.eval_ctx) (op : E.operand) : string = + let fmt = PA.eval_ctx_to_ast_formatter ctx in + PA.operand_to_string fmt op + + let statement_to_string (ctx : C.eval_ctx) (indent : string) + (indent_incr : string) (e : A.statement) : string = + let fmt = PA.eval_ctx_to_ast_formatter ctx in + PA.statement_to_string fmt indent indent_incr e +end diff --git a/compiler/PrintPure.ml b/compiler/PrintPure.ml new file mode 100644 index 00000000..a9e42f6c --- /dev/null +++ b/compiler/PrintPure.ml @@ -0,0 +1,594 @@ +(** This module defines printing functions for the types defined in Pure.ml *) + +open Pure +open PureUtils + +type type_formatter = { + type_var_id_to_string : TypeVarId.id -> string; + type_decl_id_to_string : TypeDeclId.id -> string; +} + +type value_formatter = { + type_var_id_to_string : TypeVarId.id -> string; + type_decl_id_to_string : TypeDeclId.id -> string; + adt_variant_to_string : TypeDeclId.id -> VariantId.id -> string; + var_id_to_string : VarId.id -> string; + adt_field_names : TypeDeclId.id -> VariantId.id option -> string list option; +} + +let value_to_type_formatter (fmt : value_formatter) : type_formatter = + { + type_var_id_to_string = fmt.type_var_id_to_string; + type_decl_id_to_string = fmt.type_decl_id_to_string; + } + +(* TODO: we need to store which variables we have encountered so far, and + remove [var_id_to_string]. +*) +type ast_formatter = { + type_var_id_to_string : TypeVarId.id -> string; + type_decl_id_to_string : TypeDeclId.id -> string; + adt_variant_to_string : TypeDeclId.id -> VariantId.id -> string; + var_id_to_string : VarId.id -> string; + adt_field_to_string : + TypeDeclId.id -> VariantId.id option -> FieldId.id -> string option; + adt_field_names : TypeDeclId.id -> VariantId.id option -> string list option; + fun_decl_id_to_string : FunDeclId.id -> string; + global_decl_id_to_string : GlobalDeclId.id -> string; +} + +let ast_to_value_formatter (fmt : ast_formatter) : value_formatter = + { + type_var_id_to_string = fmt.type_var_id_to_string; + type_decl_id_to_string = fmt.type_decl_id_to_string; + adt_variant_to_string = fmt.adt_variant_to_string; + var_id_to_string = fmt.var_id_to_string; + adt_field_names = fmt.adt_field_names; + } + +let ast_to_type_formatter (fmt : ast_formatter) : type_formatter = + let fmt = ast_to_value_formatter fmt in + value_to_type_formatter fmt + +let name_to_string = Print.name_to_string +let fun_name_to_string = Print.fun_name_to_string +let global_name_to_string = Print.global_name_to_string +let option_to_string = Print.option_to_string +let type_var_to_string = Print.Types.type_var_to_string +let integer_type_to_string = Print.Types.integer_type_to_string +let scalar_value_to_string = Print.Values.scalar_value_to_string + +let mk_type_formatter (type_decls : T.type_decl TypeDeclId.Map.t) + (type_params : type_var list) : type_formatter = + let type_var_id_to_string vid = + let var = T.TypeVarId.nth type_params vid in + type_var_to_string var + in + let type_decl_id_to_string def_id = + let def = T.TypeDeclId.Map.find def_id type_decls in + name_to_string def.name + in + { type_var_id_to_string; type_decl_id_to_string } + +(* TODO: there is a bit of duplication with Print.fun_decl_to_ast_formatter. + + TODO: use the pure defs as inputs? Note that it is a bit annoying for the + functions (there is a difference between the forward/backward functions...) + while we only need those definitions to lookup proper names for the def ids. +*) +let mk_ast_formatter (type_decls : T.type_decl TypeDeclId.Map.t) + (fun_decls : A.fun_decl FunDeclId.Map.t) + (global_decls : A.global_decl GlobalDeclId.Map.t) + (type_params : type_var list) : ast_formatter = + let type_var_id_to_string vid = + let var = T.TypeVarId.nth type_params vid in + type_var_to_string var + in + let type_decl_id_to_string def_id = + let def = T.TypeDeclId.Map.find def_id type_decls in + name_to_string def.name + in + let adt_variant_to_string = + Print.Contexts.type_ctx_to_adt_variant_to_string_fun type_decls + in + let var_id_to_string vid = + (* TODO: somehow lookup in the context *) + "^" ^ VarId.to_string vid + in + let adt_field_names = + Print.Contexts.type_ctx_to_adt_field_names_fun type_decls + in + let adt_field_to_string = + Print.LlbcAst.type_ctx_to_adt_field_to_string_fun type_decls + in + let fun_decl_id_to_string def_id = + let def = FunDeclId.Map.find def_id fun_decls in + fun_name_to_string def.name + in + let global_decl_id_to_string def_id = + let def = GlobalDeclId.Map.find def_id global_decls in + global_name_to_string def.name + in + { + type_var_id_to_string; + type_decl_id_to_string; + adt_variant_to_string; + var_id_to_string; + adt_field_names; + adt_field_to_string; + fun_decl_id_to_string; + global_decl_id_to_string; + } + +let type_id_to_string (fmt : type_formatter) (id : type_id) : string = + match id with + | AdtId id -> fmt.type_decl_id_to_string id + | Tuple -> "" + | Assumed aty -> ( + match aty with + | State -> "State" + | Result -> "Result" + | Option -> "Option" + | Vec -> "Vec") + +let rec ty_to_string (fmt : type_formatter) (ty : ty) : string = + match ty with + | Adt (id, tys) -> ( + let tys = List.map (ty_to_string fmt) tys in + match id with + | Tuple -> "(" ^ String.concat " * " tys ^ ")" + | AdtId _ | Assumed _ -> + let tys = if tys = [] then "" else " " ^ String.concat " " tys in + type_id_to_string fmt id ^ tys) + | TypeVar tv -> fmt.type_var_id_to_string tv + | Bool -> "bool" + | Char -> "char" + | Integer int_ty -> integer_type_to_string int_ty + | Str -> "str" + | Array aty -> "[" ^ ty_to_string fmt aty ^ "; ?]" + | Slice sty -> "[" ^ ty_to_string fmt sty ^ "]" + | Arrow (arg_ty, ret_ty) -> + ty_to_string fmt arg_ty ^ " -> " ^ ty_to_string fmt ret_ty + +let field_to_string fmt (f : field) : string = + match f.field_name with + | None -> ty_to_string fmt f.field_ty + | Some field_name -> field_name ^ " : " ^ ty_to_string fmt f.field_ty + +let variant_to_string fmt (v : variant) : string = + v.variant_name ^ "(" + ^ String.concat ", " (List.map (field_to_string fmt) v.fields) + ^ ")" + +let type_decl_to_string (fmt : type_formatter) (def : type_decl) : string = + let types = def.type_params in + let name = name_to_string def.name in + let params = + if types = [] then "" + else " " ^ String.concat " " (List.map type_var_to_string types) + in + match def.kind with + | Struct fields -> + if List.length fields > 0 then + let fields = + String.concat "," + (List.map (fun f -> "\n " ^ field_to_string fmt f) fields) + in + "struct " ^ name ^ params ^ "{" ^ fields ^ "}" + else "struct " ^ name ^ params ^ "{}" + | Enum variants -> + let variants = + List.map (fun v -> "| " ^ variant_to_string fmt v) variants + in + let variants = String.concat "\n" variants in + "enum " ^ name ^ params ^ " =\n" ^ variants + | Opaque -> "opaque type " ^ name ^ params + +let var_to_varname (v : var) : string = + match v.basename with + | Some name -> name ^ "^" ^ VarId.to_string v.id + | None -> "^" ^ VarId.to_string v.id + +let var_to_string (fmt : type_formatter) (v : var) : string = + let varname = var_to_varname v in + "(" ^ varname ^ " : " ^ ty_to_string fmt v.ty ^ ")" + +let rec mprojection_to_string (fmt : ast_formatter) (inside : string) + (p : mprojection) : string = + match p with + | [] -> inside + | pe :: p' -> ( + let s = mprojection_to_string fmt inside p' in + match pe.pkind with + | E.ProjOption variant_id -> + assert (variant_id = T.option_some_id); + assert (pe.field_id = T.FieldId.zero); + "(" ^ s ^ "as Option::Some)." ^ T.FieldId.to_string pe.field_id + | E.ProjTuple _ -> "(" ^ s ^ ")." ^ T.FieldId.to_string pe.field_id + | E.ProjAdt (adt_id, opt_variant_id) -> ( + let field_name = + match fmt.adt_field_to_string adt_id opt_variant_id pe.field_id with + | Some field_name -> field_name + | None -> T.FieldId.to_string pe.field_id + in + match opt_variant_id with + | None -> "(" ^ s ^ ")." ^ field_name + | Some variant_id -> + let variant_name = fmt.adt_variant_to_string adt_id variant_id in + "(" ^ s ^ " as " ^ variant_name ^ ")." ^ field_name)) + +let mplace_to_string (fmt : ast_formatter) (p : mplace) : string = + let name = match p.name with None -> "" | Some name -> name in + (* We add the "llbc" suffix to the variable index, because meta-places + * use indices of the variables in the original LLBC program, while + * regular places use indices for the pure variables: we want to make + * this explicit, otherwise it is confusing. *) + let name = name ^ "^" ^ V.VarId.to_string p.var_id ^ "llbc" in + mprojection_to_string fmt name p.projection + +let adt_variant_to_string (fmt : value_formatter) (adt_id : type_id) + (variant_id : VariantId.id option) : string = + match adt_id with + | Tuple -> "Tuple" + | AdtId def_id -> ( + (* "Regular" ADT *) + match variant_id with + | Some vid -> fmt.adt_variant_to_string def_id vid + | None -> fmt.type_decl_id_to_string def_id) + | Assumed aty -> ( + (* Assumed type *) + match aty with + | State -> + (* The [State] type is opaque: we can't get there *) + raise (Failure "Unreachable") + | Result -> + let variant_id = Option.get variant_id in + if variant_id = result_return_id then "@Result::Return" + else if variant_id = result_fail_id then "@Result::Fail" + else + raise (Failure "Unreachable: improper variant id for result type") + | Option -> + let variant_id = Option.get variant_id in + if variant_id = option_some_id then "@Option::Some " + else if variant_id = option_none_id then "@Option::None" + else + raise (Failure "Unreachable: improper variant id for result type") + | Vec -> + assert (variant_id = None); + "Vec") + +let adt_field_to_string (fmt : value_formatter) (adt_id : type_id) + (field_id : FieldId.id) : string = + match adt_id with + | Tuple -> + raise (Failure "Unreachable") + (* Tuples don't use the opaque field id for the field indices, but [int] *) + | AdtId def_id -> ( + (* "Regular" ADT *) + let fields = fmt.adt_field_names def_id None in + match fields with + | None -> FieldId.to_string field_id + | Some fields -> FieldId.nth fields field_id) + | Assumed aty -> ( + (* Assumed type *) + match aty with + | State | Vec -> + (* Opaque types: we can't get there *) + raise (Failure "Unreachable") + | Result | Option -> + (* Enumerations: we can't get there *) + raise (Failure "Unreachable")) + +(** TODO: we don't need a general function anymore (it is now only used for + patterns (i.e., patterns) + *) +let adt_g_value_to_string (fmt : value_formatter) + (value_to_string : 'v -> string) (variant_id : VariantId.id option) + (field_values : 'v list) (ty : ty) : string = + let field_values = List.map value_to_string field_values in + match ty with + | Adt (Tuple, _) -> + (* Tuple *) + "(" ^ String.concat ", " field_values ^ ")" + | Adt (AdtId def_id, _) -> + (* "Regular" ADT *) + let adt_ident = + match variant_id with + | Some vid -> fmt.adt_variant_to_string def_id vid + | None -> fmt.type_decl_id_to_string def_id + in + if field_values <> [] then + match fmt.adt_field_names def_id variant_id with + | None -> + let field_values = String.concat ", " field_values in + adt_ident ^ " (" ^ field_values ^ ")" + | Some field_names -> + let field_values = List.combine field_names field_values in + let field_values = + List.map + (fun (field, value) -> field ^ " = " ^ value ^ ";") + field_values + in + let field_values = String.concat " " field_values in + adt_ident ^ " { " ^ field_values ^ " }" + else adt_ident + | Adt (Assumed aty, _) -> ( + (* Assumed type *) + match aty with + | State -> + (* The [State] type is opaque: we can't get there *) + raise (Failure "Unreachable") + | Result -> + let variant_id = Option.get variant_id in + if variant_id = result_return_id then + match field_values with + | [ v ] -> "@Result::Return " ^ v + | _ -> raise (Failure "Result::Return takes exactly one value") + else if variant_id = result_fail_id then ( + assert (field_values = []); + "@Result::Fail") + else + raise (Failure "Unreachable: improper variant id for result type") + | Option -> + let variant_id = Option.get variant_id in + if variant_id = option_some_id then + match field_values with + | [ v ] -> "@Option::Some " ^ v + | _ -> raise (Failure "Option::Some takes exactly one value") + else if variant_id = option_none_id then ( + assert (field_values = []); + "@Option::None") + else + raise (Failure "Unreachable: improper variant id for result type") + | Vec -> + assert (variant_id = None); + let field_values = + List.mapi (fun i v -> string_of_int i ^ " -> " ^ v) field_values + in + "Vec [" ^ String.concat "; " field_values ^ "]") + | _ -> + let fmt = value_to_type_formatter fmt in + raise + (Failure + ("Inconsistently typed value: expected ADT type but found:" + ^ "\n- ty: " ^ ty_to_string fmt ty ^ "\n- variant_id: " + ^ Print.option_to_string VariantId.to_string variant_id)) + +let rec typed_pattern_to_string (fmt : ast_formatter) (v : typed_pattern) : + string = + match v.value with + | PatConcrete cv -> Print.Values.constant_value_to_string cv + | PatVar (v, None) -> var_to_string (ast_to_type_formatter fmt) v + | PatVar (v, Some mp) -> + let mp = "[@mplace=" ^ mplace_to_string fmt mp ^ "]" in + "(" ^ var_to_varname v ^ " " ^ mp ^ " : " + ^ ty_to_string (ast_to_type_formatter fmt) v.ty + ^ ")" + | PatDummy -> "_" + | PatAdt av -> + adt_g_value_to_string + (ast_to_value_formatter fmt) + (typed_pattern_to_string fmt) + av.variant_id av.field_values v.ty + +let fun_sig_to_string (fmt : ast_formatter) (sg : fun_sig) : string = + let ty_fmt = ast_to_type_formatter fmt in + let type_params = List.map type_var_to_string sg.type_params in + let inputs = List.map (ty_to_string ty_fmt) sg.inputs in + let output = ty_to_string ty_fmt sg.output in + let all_types = List.concat [ type_params; inputs; [ output ] ] in + String.concat " -> " all_types + +let inst_fun_sig_to_string (fmt : ast_formatter) (sg : inst_fun_sig) : string = + let ty_fmt = ast_to_type_formatter fmt in + let inputs = List.map (ty_to_string ty_fmt) sg.inputs in + let output = ty_to_string ty_fmt sg.output in + let all_types = List.append inputs [ output ] in + String.concat " -> " all_types + +let regular_fun_id_to_string (fmt : ast_formatter) (fun_id : A.fun_id) : string + = + match fun_id with + | A.Regular fid -> fmt.fun_decl_id_to_string fid + | A.Assumed fid -> ( + match fid with + | A.Replace -> "core::mem::replace" + | A.BoxNew -> "alloc::boxed::Box::new" + | A.BoxDeref -> "core::ops::deref::Deref::deref" + | A.BoxDerefMut -> "core::ops::deref::DerefMut::deref_mut" + | A.BoxFree -> "alloc::alloc::box_free" + | A.VecNew -> "alloc::vec::Vec::new" + | A.VecPush -> "alloc::vec::Vec::push" + | A.VecInsert -> "alloc::vec::Vec::insert" + | A.VecLen -> "alloc::vec::Vec::len" + | A.VecIndex -> "core::ops::index::Index<alloc::vec::Vec>::index" + | A.VecIndexMut -> + "core::ops::index::IndexMut<alloc::vec::Vec>::index_mut") + +let fun_suffix (rg_id : T.RegionGroupId.id option) : string = + match rg_id with + | None -> "" + | Some rg_id -> "@" ^ T.RegionGroupId.to_string rg_id + +let unop_to_string (unop : unop) : string = + match unop with + | Not -> "¬" + | Neg _ -> "-" + | Cast (src, tgt) -> + "cast<" ^ integer_type_to_string src ^ "," ^ integer_type_to_string tgt + ^ ">" + +let binop_to_string = Print.LlbcAst.binop_to_string + +let fun_id_to_string (fmt : ast_formatter) (fun_id : fun_id) : string = + match fun_id with + | Regular (fun_id, rg_id) -> + let f = regular_fun_id_to_string fmt fun_id in + f ^ fun_suffix rg_id + | Unop unop -> unop_to_string unop + | Binop (binop, int_ty) -> + binop_to_string binop ^ "<" ^ integer_type_to_string int_ty ^ ">" + +(** [inside]: controls the introduction of parentheses *) +let rec texpression_to_string (fmt : ast_formatter) (inside : bool) + (indent : string) (indent_incr : string) (e : texpression) : string = + match e.e with + | Var var_id -> + let s = fmt.var_id_to_string var_id in + if inside then "(" ^ s ^ ")" else s + | Const cv -> Print.Values.constant_value_to_string cv + | App _ -> + (* Recursively destruct the app, to have a pair (app, arguments list) *) + let app, args = destruct_apps e in + (* Convert to string *) + app_to_string fmt inside indent indent_incr app args + | Abs _ -> + let xl, e = destruct_abs_list e in + let e = abs_to_string fmt indent indent_incr xl e in + if inside then "(" ^ e ^ ")" else e + | Qualif _ -> + (* Qualifier without arguments *) + app_to_string fmt inside indent indent_incr e [] + | Let (monadic, lv, re, e) -> + let e = let_to_string fmt indent indent_incr monadic lv re e in + if inside then "(" ^ e ^ ")" else e + | Switch (scrutinee, body) -> + let e = switch_to_string fmt indent indent_incr scrutinee body in + if inside then "(" ^ e ^ ")" else e + | Meta (meta, e) -> ( + let meta_s = meta_to_string fmt meta in + let e = texpression_to_string fmt inside indent indent_incr e in + match meta with + | Assignment _ -> + let e = meta_s ^ "\n" ^ indent ^ e in + if inside then "(" ^ e ^ ")" else e + | MPlace _ -> "(" ^ meta_s ^ " " ^ e ^ ")") + +and app_to_string (fmt : ast_formatter) (inside : bool) (indent : string) + (indent_incr : string) (app : texpression) (args : texpression list) : + string = + (* There are two possibilities: either the [app] is an instantiated, + * top-level qualifier (function, ADT constructore...), or it is a "regular" + * expression *) + let app, tys = + match app.e with + | Qualif qualif -> + (* Qualifier case *) + (* Convert the qualifier identifier *) + let qualif_s = + match qualif.id with + | Func fun_id -> fun_id_to_string fmt fun_id + | Global global_id -> fmt.global_decl_id_to_string global_id + | AdtCons adt_cons_id -> + let variant_s = + adt_variant_to_string + (ast_to_value_formatter fmt) + adt_cons_id.adt_id adt_cons_id.variant_id + in + ConstStrings.constructor_prefix ^ variant_s + | Proj { adt_id; field_id } -> + let value_fmt = ast_to_value_formatter fmt in + let adt_s = adt_variant_to_string value_fmt adt_id None in + let field_s = adt_field_to_string value_fmt adt_id field_id in + (* Adopting an F*-like syntax *) + ConstStrings.constructor_prefix ^ adt_s ^ "?." ^ field_s + in + (* Convert the type instantiation *) + let ty_fmt = ast_to_type_formatter fmt in + let tys = List.map (ty_to_string ty_fmt) qualif.type_args in + (* *) + (qualif_s, tys) + | _ -> + (* "Regular" expression case *) + let inside = args <> [] || (args = [] && inside) in + (texpression_to_string fmt inside indent indent_incr app, []) + in + (* Convert the arguments. + * The arguments are expressions, so indentation might get weird... (though + * those expressions will in most cases just be values) *) + let arg_to_string = + let inside = true in + let indent1 = indent ^ indent_incr in + texpression_to_string fmt inside indent1 indent_incr + in + let args = List.map arg_to_string args in + let all_args = List.append tys args in + (* Put together *) + let e = + if all_args = [] then app else app ^ " " ^ String.concat " " all_args + in + (* Add parentheses *) + if all_args <> [] && inside then "(" ^ e ^ ")" else e + +and abs_to_string (fmt : ast_formatter) (indent : string) (indent_incr : string) + (xl : typed_pattern list) (e : texpression) : string = + let xl = List.map (typed_pattern_to_string fmt) xl in + let e = texpression_to_string fmt false indent indent_incr e in + "λ " ^ String.concat " " xl ^ ". " ^ e + +and let_to_string (fmt : ast_formatter) (indent : string) (indent_incr : string) + (monadic : bool) (lv : typed_pattern) (re : texpression) (e : texpression) : + string = + let indent1 = indent ^ indent_incr in + let inside = false in + let re = texpression_to_string fmt inside indent1 indent_incr re in + let e = texpression_to_string fmt inside indent indent_incr e in + let lv = typed_pattern_to_string fmt lv in + if monadic then lv ^ " <-- " ^ re ^ ";\n" ^ indent ^ e + else "let " ^ lv ^ " = " ^ re ^ " in\n" ^ indent ^ e + +and switch_to_string (fmt : ast_formatter) (indent : string) + (indent_incr : string) (scrutinee : texpression) (body : switch_body) : + string = + let indent1 = indent ^ indent_incr in + (* Printing can mess up on the scrutinee, because it is an expression - but + * in most situations it will be a value or a function call, so it should be + * ok*) + let scrut = texpression_to_string fmt true indent1 indent_incr scrutinee in + let e_to_string = texpression_to_string fmt false indent1 indent_incr in + match body with + | If (e_true, e_false) -> + let e_true = e_to_string e_true in + let e_false = e_to_string e_false in + "if " ^ scrut ^ "\n" ^ indent ^ "then\n" ^ indent1 ^ e_true ^ "\n" + ^ indent ^ "else\n" ^ indent1 ^ e_false + | Match branches -> + let branch_to_string (b : match_branch) : string = + let pat = typed_pattern_to_string fmt b.pat in + indent ^ "| " ^ pat ^ " ->\n" ^ indent1 ^ e_to_string b.branch + in + let branches = List.map branch_to_string branches in + "match " ^ scrut ^ " with\n" ^ String.concat "\n" branches + +and meta_to_string (fmt : ast_formatter) (meta : meta) : string = + let meta = + match meta with + | Assignment (lp, rv, rp) -> + let rp = + match rp with + | None -> "" + | Some rp -> " [@src=" ^ mplace_to_string fmt rp ^ "]" + in + "@assign(" ^ mplace_to_string fmt lp ^ " := " + ^ texpression_to_string fmt false "" "" rv + ^ rp ^ ")" + | MPlace mp -> "@mplace=" ^ mplace_to_string fmt mp + in + "@meta[" ^ meta ^ "]" + +let fun_decl_to_string (fmt : ast_formatter) (def : fun_decl) : string = + let type_fmt = ast_to_type_formatter fmt in + let name = fun_name_to_string def.basename ^ fun_suffix def.back_id in + let signature = fun_sig_to_string fmt def.signature in + match def.body with + | None -> "val " ^ name ^ " :\n " ^ signature + | Some body -> + let inside = false in + let indent = " " in + let inputs = List.map (var_to_string type_fmt) body.inputs in + let inputs = + if inputs = [] then indent + else " fun " ^ String.concat " " inputs ^ " ->\n" ^ indent + in + let body = texpression_to_string fmt inside indent indent body.body in + "let " ^ name ^ " :\n " ^ signature ^ " =\n" ^ inputs ^ body diff --git a/compiler/Pure.ml b/compiler/Pure.ml new file mode 100644 index 00000000..77265f75 --- /dev/null +++ b/compiler/Pure.ml @@ -0,0 +1,581 @@ +open Identifiers +open Names +module T = Types +module V = Values +module E = Expressions +module A = LlbcAst +module TypeDeclId = T.TypeDeclId +module TypeVarId = T.TypeVarId +module RegionGroupId = T.RegionGroupId +module VariantId = T.VariantId +module FieldId = T.FieldId +module SymbolicValueId = V.SymbolicValueId +module FunDeclId = A.FunDeclId +module GlobalDeclId = A.GlobalDeclId + +(** We give an identifier to every phase of the synthesis (forward, backward + for group of regions 0, etc.) *) +module SynthPhaseId = IdGen () + +(** Pay attention to the fact that we also define a {!Values.VarId} module in Values *) +module VarId = IdGen () + +type integer_type = T.integer_type [@@deriving show, ord] + +(** The assumed types for the pure AST. + + In comparison with LLBC: + - we removed [Box] (because it is translated as the identity: [Box T == T]) + - we added: + - [Result]: the type used in the error monad. This allows us to have a + unified treatment of expressions (especially when we have to unfold the + monadic binds) + - [State]: the type of the state, when using state-error monads. Note that + this state is opaque to Aeneas (the user can define it, or leave it as + assumed) + *) +type assumed_ty = State | Result | Vec | Option [@@deriving show, ord] + +(* TODO: we should never directly manipulate [Return] and [Fail], but rather + * the monadic functions [return] and [fail] (makes treatment of error and + * state-error monads more uniform) *) +let result_return_id = VariantId.of_int 0 +let result_fail_id = VariantId.of_int 1 +let option_some_id = T.option_some_id +let option_none_id = T.option_none_id + +type type_id = AdtId of TypeDeclId.id | Tuple | Assumed of assumed_ty +[@@deriving show, ord] + +(** Ancestor for iter visitor for [ty] *) +class ['self] iter_ty_base = + object (_self : 'self) + inherit [_] VisitorsRuntime.iter + method visit_id : 'env -> TypeVarId.id -> unit = fun _ _ -> () + method visit_type_id : 'env -> type_id -> unit = fun _ _ -> () + method visit_integer_type : 'env -> integer_type -> unit = fun _ _ -> () + end + +(** Ancestor for map visitor for [ty] *) +class ['self] map_ty_base = + object (_self : 'self) + inherit [_] VisitorsRuntime.map + method visit_id : 'env -> TypeVarId.id -> TypeVarId.id = fun _ id -> id + method visit_type_id : 'env -> type_id -> type_id = fun _ id -> id + + method visit_integer_type : 'env -> integer_type -> integer_type = + fun _ ity -> ity + end + +type ty = + | Adt of type_id * ty list + (** {!Adt} encodes ADTs and tuples and assumed types. + + TODO: what about the ended regions? (ADTs may be parameterized + with several region variables. When giving back an ADT value, we may + be able to only give back part of the ADT. We need a way to encode + such "partial" ADTs. + *) + | TypeVar of TypeVarId.id + | Bool + | Char + | Integer of integer_type + | Str + | Array of ty (* TODO: this should be an assumed type?... *) + | Slice of ty (* TODO: this should be an assumed type?... *) + | Arrow of ty * ty +[@@deriving + show, + visitors + { + name = "iter_ty"; + variety = "iter"; + ancestors = [ "iter_ty_base" ]; + nude = true (* Don't inherit {!VisitorsRuntime.iter} *); + concrete = true; + polymorphic = false; + }, + visitors + { + name = "map_ty"; + variety = "map"; + ancestors = [ "map_ty_base" ]; + nude = true (* Don't inherit {!VisitorsRuntime.iter} *); + concrete = true; + polymorphic = false; + }] + +type field = { field_name : string option; field_ty : ty } [@@deriving show] +type variant = { variant_name : string; fields : field list } [@@deriving show] + +type type_decl_kind = Struct of field list | Enum of variant list | Opaque +[@@deriving show] + +type type_var = T.type_var [@@deriving show] + +type type_decl = { + def_id : TypeDeclId.id; + name : name; + type_params : type_var list; + kind : type_decl_kind; +} +[@@deriving show] + +type scalar_value = V.scalar_value [@@deriving show] +type constant_value = V.constant_value [@@deriving show] + +(** Because we introduce a lot of temporary variables, the list of variables + is not fixed: we thus must carry all its information with the variable + itself. + *) +type var = { + id : VarId.id; + basename : string option; + (** The "basename" is used to generate a meaningful name for the variable + (by potentially adding an index to uniquely identify it). + *) + ty : ty; +} +[@@deriving show] + +(* TODO: we might want to redefine field_proj_kind here, to prevent field accesses + * on enumerations. + * Also: tuples... + * Rmk: projections are actually only used as meta-data. + * *) +type mprojection_elem = { pkind : E.field_proj_kind; field_id : FieldId.id } +[@@deriving show] + +type mprojection = mprojection_elem list [@@deriving show] + +(** "Meta" place. + + Meta-data retrieved from the symbolic execution, which gives provenance + information about the values. We use this to generate names for the variables + we introduce. + *) +type mplace = { + var_id : V.VarId.id; + name : string option; + projection : mprojection; +} +[@@deriving show] + +type variant_id = VariantId.id [@@deriving show] + +(** Ancestor for [iter_pat_var_or_dummy] visitor *) +class ['self] iter_value_base = + object (_self : 'self) + inherit [_] VisitorsRuntime.iter + method visit_constant_value : 'env -> constant_value -> unit = fun _ _ -> () + method visit_var : 'env -> var -> unit = fun _ _ -> () + method visit_mplace : 'env -> mplace -> unit = fun _ _ -> () + method visit_ty : 'env -> ty -> unit = fun _ _ -> () + method visit_variant_id : 'env -> variant_id -> unit = fun _ _ -> () + end + +(** Ancestor for [map_typed_rvalue] visitor *) +class ['self] map_value_base = + object (_self : 'self) + inherit [_] VisitorsRuntime.map + + method visit_constant_value : 'env -> constant_value -> constant_value = + fun _ x -> x + + method visit_var : 'env -> var -> var = fun _ x -> x + method visit_mplace : 'env -> mplace -> mplace = fun _ x -> x + method visit_ty : 'env -> ty -> ty = fun _ x -> x + method visit_variant_id : 'env -> variant_id -> variant_id = fun _ x -> x + end + +(** Ancestor for [reduce_typed_rvalue] visitor *) +class virtual ['self] reduce_value_base = + object (self : 'self) + inherit [_] VisitorsRuntime.reduce + + method visit_constant_value : 'env -> constant_value -> 'a = + fun _ _ -> self#zero + + method visit_var : 'env -> var -> 'a = fun _ _ -> self#zero + method visit_mplace : 'env -> mplace -> 'a = fun _ _ -> self#zero + method visit_ty : 'env -> ty -> 'a = fun _ _ -> self#zero + method visit_variant_id : 'env -> variant_id -> 'a = fun _ _ -> self#zero + end + +(** Ancestor for [mapreduce_typed_rvalue] visitor *) +class virtual ['self] mapreduce_value_base = + object (self : 'self) + inherit [_] VisitorsRuntime.mapreduce + + method visit_constant_value : 'env -> constant_value -> constant_value * 'a + = + fun _ x -> (x, self#zero) + + method visit_var : 'env -> var -> var * 'a = fun _ x -> (x, self#zero) + + method visit_mplace : 'env -> mplace -> mplace * 'a = + fun _ x -> (x, self#zero) + + method visit_ty : 'env -> ty -> ty * 'a = fun _ x -> (x, self#zero) + + method visit_variant_id : 'env -> variant_id -> variant_id * 'a = + fun _ x -> (x, self#zero) + end + +(** A pattern (which appears on the left of assignments, in matches, etc.). *) +type pattern = + | PatConcrete of constant_value + (** {!PatConcrete} is necessary because we merge the switches over integer + values and the matches over enumerations *) + | PatVar of var * mplace option + | PatDummy (** Ignored value: [_]. *) + | PatAdt of adt_pattern + +and adt_pattern = { + variant_id : variant_id option; + field_values : typed_pattern list; +} + +and typed_pattern = { value : pattern; ty : ty } +[@@deriving + show, + visitors + { + name = "iter_typed_pattern"; + variety = "iter"; + ancestors = [ "iter_value_base" ]; + nude = true (* Don't inherit {!VisitorsRuntime.iter} *); + concrete = true; + polymorphic = false; + }, + visitors + { + name = "map_typed_pattern"; + variety = "map"; + ancestors = [ "map_value_base" ]; + nude = true (* Don't inherit {!VisitorsRuntime.iter} *); + concrete = true; + polymorphic = false; + }, + visitors + { + name = "reduce_typed_pattern"; + variety = "reduce"; + ancestors = [ "reduce_value_base" ]; + nude = true (* Don't inherit {!VisitorsRuntime.iter} *); + polymorphic = false; + }, + visitors + { + name = "mapreduce_typed_pattern"; + variety = "mapreduce"; + ancestors = [ "mapreduce_value_base" ]; + nude = true (* Don't inherit {!VisitorsRuntime.iter} *); + polymorphic = false; + }] + +type unop = Not | Neg of integer_type | Cast of integer_type * integer_type +[@@deriving show, ord] + +type fun_id = + | Regular of A.fun_id * T.RegionGroupId.id option + (** Backward id: [Some] if the function is a backward function, [None] + if it is a forward function. + + TODO: we need to redefine A.fun_id here, to add [fail] and + [return] (important to get a unified treatment of the state-error + monad). For now, when using the state-error monad: extraction + works only if we unfold all the monadic let-bindings, and we + then replace the content of the occurrences of [Return] to also + return the state (which is really super ugly). + *) + | Unop of unop + | Binop of E.binop * integer_type +[@@deriving show, ord] + +(** An identifier for an ADT constructor *) +type adt_cons_id = { adt_id : type_id; variant_id : variant_id option } +[@@deriving show] + +(** Projection - For now we don't support projection of tuple fields + (because not all the backends have syntax for this). + *) +type projection = { adt_id : type_id; field_id : FieldId.id } [@@deriving show] + +type qualif_id = + | Func of fun_id + | Global of GlobalDeclId.id + | AdtCons of adt_cons_id (** A function or ADT constructor identifier *) + | Proj of projection (** Field projector *) +[@@deriving show] + +(** An instantiated qualified. + + Note that for now we have a clear separation between types and expressions, + which explains why we have the [type_params] field: a function or ADT + constructor is always fully instantiated. + *) +type qualif = { id : qualif_id; type_args : ty list } [@@deriving show] + +type var_id = VarId.id [@@deriving show] + +(** Ancestor for [iter_expression] visitor *) +class ['self] iter_expression_base = + object (_self : 'self) + inherit [_] iter_typed_pattern + method visit_integer_type : 'env -> integer_type -> unit = fun _ _ -> () + method visit_var_id : 'env -> var_id -> unit = fun _ _ -> () + method visit_qualif : 'env -> qualif -> unit = fun _ _ -> () + end + +(** Ancestor for [map_expression] visitor *) +class ['self] map_expression_base = + object (_self : 'self) + inherit [_] map_typed_pattern + + method visit_integer_type : 'env -> integer_type -> integer_type = + fun _ x -> x + + method visit_var_id : 'env -> var_id -> var_id = fun _ x -> x + method visit_qualif : 'env -> qualif -> qualif = fun _ x -> x + end + +(** Ancestor for [reduce_expression] visitor *) +class virtual ['self] reduce_expression_base = + object (self : 'self) + inherit [_] reduce_typed_pattern + + method visit_integer_type : 'env -> integer_type -> 'a = + fun _ _ -> self#zero + + method visit_var_id : 'env -> var_id -> 'a = fun _ _ -> self#zero + method visit_qualif : 'env -> qualif -> 'a = fun _ _ -> self#zero + end + +(** Ancestor for [mapreduce_expression] visitor *) +class virtual ['self] mapreduce_expression_base = + object (self : 'self) + inherit [_] mapreduce_typed_pattern + + method visit_integer_type : 'env -> integer_type -> integer_type * 'a = + fun _ x -> (x, self#zero) + + method visit_var_id : 'env -> var_id -> var_id * 'a = + fun _ x -> (x, self#zero) + + method visit_qualif : 'env -> qualif -> qualif * 'a = + fun _ x -> (x, self#zero) + end + +(** **Rk.:** here, {!expression} is not at all equivalent to the expressions + used in LLBC. They are lambda-calculus expressions, and are thus actually + more general than the LLBC statements, in a sense. + *) +type expression = + | Var of var_id (** a variable *) + | Const of constant_value + | App of texpression * texpression + (** Application of a function to an argument. + + The function calls are still quite structured. + Change that?... We might want to have a "normal" lambda calculus + app (with head and argument): this would allow us to replace some + field accesses with calls to projectors over fields (when there + are clashes of field names, some provers like F* get pretty bad...) + *) + | Abs of typed_pattern * texpression (** Lambda abstraction: [fun x -> e] *) + | Qualif of qualif (** A top-level qualifier *) + | Let of bool * typed_pattern * texpression * texpression + (** Let binding. + + TODO: the boolean should be replaced by an enum: sometimes we use + the error-monad, sometimes we use the state-error monad (and we + do this an a per-function basis! For instance, arithmetic functions + are always in the error monad). + + The boolean controls whether the let is monadic or not. + For instance, in F*: + - non-monadic: [let x = ... in ...] + - monadic: [x <-- ...; ...] + + Note that we are quite general for the left-value on purpose; this + is used in several situations: + + 1. When deconstructing a tuple: + {[ + let (x, y) = p in ... + ]} + (not all languages have syntax like [p.0], [p.1]... and it is more + readable anyway). + + 2. When expanding an enumeration with one variant. + In this case, {!Let} has to be understood as: + {[ + let Cons x tl = ls in + ... + ]} + + Note that later, depending on the language we extract to, we can + eventually update it to something like this (for F*, for instance): + {[ + let x = Cons?.v ls in + let tl = Cons?.tl ls in + ... + ]} + *) + | Switch of texpression * switch_body + | Meta of (meta[@opaque]) * texpression (** Meta-information *) + +and switch_body = If of texpression * texpression | Match of match_branch list +and match_branch = { pat : typed_pattern; branch : texpression } +and texpression = { e : expression; ty : ty } + +(** Meta-value (converted to an expression). It is important that the content + is opaque. + + TODO: is it possible to mark the whole mvalue type as opaque? + *) +and mvalue = (texpression[@opaque]) + +and meta = + | Assignment of mplace * mvalue * mplace option + (** Meta-information stored in the AST. + + The first mplace stores the destination. + The mvalue stores the value which is put in the destination + The second (optional) mplace stores the origin. + *) + | MPlace of mplace (** Meta-information about the origin of a value *) +[@@deriving + show, + visitors + { + name = "iter_expression"; + variety = "iter"; + ancestors = [ "iter_expression_base" ]; + nude = true (* Don't inherit {!VisitorsRuntime.iter} *); + concrete = true; + }, + visitors + { + name = "map_expression"; + variety = "map"; + ancestors = [ "map_expression_base" ]; + nude = true (* Don't inherit {!VisitorsRuntime.iter} *); + concrete = true; + }, + visitors + { + name = "reduce_expression"; + variety = "reduce"; + ancestors = [ "reduce_expression_base" ]; + nude = true (* Don't inherit {!VisitorsRuntime.iter} *); + }, + visitors + { + name = "mapreduce_expression"; + variety = "mapreduce"; + ancestors = [ "mapreduce_expression_base" ]; + nude = true (* Don't inherit {!VisitorsRuntime.iter} *); + }] + +(** Information about the "effect" of a function *) +type fun_effect_info = { + input_state : bool; (** [true] if the function takes a state as input *) + output_state : bool; + (** [true] if the function outputs a state (it then lives + in a state monad) *) + can_fail : bool; (** [true] if the return type is a [result] *) +} + +(** Meta information about a function signature *) +type fun_sig_info = { + num_fwd_inputs : int; + (** The number of input types for forward computation *) + num_back_inputs : int option; + (** The number of additional inputs for the backward computation (if pertinent) *) + effect_info : fun_effect_info; +} + +(** A function signature. + + We have the following cases: + - forward function: + [in_ty0 -> ... -> in_tyn -> out_ty] (* pure function *) + `in_ty0 -> ... -> in_tyn -> result out_ty` (* error-monad *) + `in_ty0 -> ... -> in_tyn -> state -> result (state & out_ty)` (* state-error *) + - backward function: + `in_ty0 -> ... -> in_tyn -> back_in0 -> ... back_inm -> (back_out0 & ... & back_outp)` (* pure function *) + `in_ty0 -> ... -> in_tyn -> back_in0 -> ... back_inm -> + result (back_out0 & ... & back_outp)` (* error-monad *) + `in_ty0 -> ... -> in_tyn -> state -> back_in0 -> ... back_inm -> + result (back_out0 & ... & back_outp)` (* state-error *) + + Note that a backward function never returns (i.e., updates) a state: only + forward functions do so. Also, the state input parameter is *betwee* + the forward inputs and the backward inputs. + + The function's type should be given by `mk_arrows sig.inputs sig.output`. + We provide additional meta-information: + - we divide between forward inputs and backward inputs (i.e., inputs specific + to the forward functions, and additional inputs necessary if the signature is + for a backward function) + - we have booleans to give us the fact that the function takes a state as + input, or can fail, etc. without having to inspect the signature + - etc. + *) +type fun_sig = { + type_params : type_var list; + inputs : ty list; + output : ty; + doutputs : ty list; + (** The "decomposed" list of outputs. + + In case of a forward function, the list has length = 1, for the + type of the returned value. + + In case of backward function, the list contains all the types of + all the given back values (there is at most one type per forward + input argument). + + Ex.: + {[ + fn choose<'a, T>(b : bool, x : &'a mut T, y : &'a mut T) -> &'a mut T; + ]} + Decomposed outputs: + - forward function: [T] + - backward function: [T; T] (for "x" and "y") + + *) + info : fun_sig_info; (** Additional information *) +} + +(** An instantiated function signature. See {!fun_sig} *) +type inst_fun_sig = { + inputs : ty list; + output : ty; + doutputs : ty list; + info : fun_sig_info; +} + +type fun_body = { + inputs : var list; + inputs_lvs : typed_pattern list; + (** The inputs seen as patterns. Allows to make transformations, for example + to replace unused variables by [_] *) + body : texpression; +} + +type fun_decl = { + def_id : FunDeclId.id; + back_id : T.RegionGroupId.id option; + basename : fun_name; + (** The "base" name of the function. + + The base name is the original name of the Rust function. We add suffixes + (to identify the forward/backward functions) later. + *) + signature : fun_sig; + is_global_decl_body : bool; + body : fun_body option; +} diff --git a/compiler/PureMicroPasses.ml b/compiler/PureMicroPasses.ml new file mode 100644 index 00000000..3edae38a --- /dev/null +++ b/compiler/PureMicroPasses.ml @@ -0,0 +1,1375 @@ +(** The following module defines micro-passes which operate on the pure AST *) + +open Pure +open PureUtils +open TranslateCore +module V = Values + +(** The local logger *) +let log = L.pure_micro_passes_log + +(** A configuration to control the application of the passes *) +type config = { + decompose_monadic_let_bindings : bool; + (** Some provers like F* don't support the decomposition of return values + in monadic let-bindings: + {[ + // NOT supported in F* + let (x, y) <-- f (); + ... + ]} + + In such situations, we might want to introduce an intermediate + assignment: + {[ + let tmp <-- f (); + let (x, y) = tmp in + ... + ]} + *) + unfold_monadic_let_bindings : bool; + (** Controls the unfolding of monadic let-bindings to explicit matches: + + [y <-- f x; ...] + + becomes: + + [match f x with | Failure -> Failure | Return y -> ...] + + + This is useful when extracting to F*: the support for monadic + definitions is not super powerful. + Note that when {!field:unfold_monadic_let_bindings} is true, setting + {!field:decompose_monadic_let_bindings} to true and only makes the code + more verbose. + *) + filter_useless_monadic_calls : bool; + (** Controls whether we try to filter the calls to monadic functions + (which can fail) when their outputs are not used. + + See the comments for {!expression_contains_child_call_in_all_paths} + for additional explanations. + + TODO: rename to {!filter_useless_monadic_calls} + *) + filter_useless_functions : bool; + (** If {!filter_useless_monadic_calls} is activated, some functions + become useless: if this option is true, we don't extract them. + + The calls to functions which always get filtered are: + - the forward functions with unit return value + - the backward functions which don't output anything (backward + functions coming from rust functions with no mutable borrows + as input values - note that if a function doesn't take mutable + borrows as inputs, it can't return mutable borrows; we actually + dynamically check for that). + *) +} + +(** Small utility. + + We sometimes have to insert new fresh variables in a function body, in which + case we need to make their indices greater than the indices of all the variables + in the body. + TODO: things would be simpler if we used a better representation of the + variables indices... + *) +let get_body_min_var_counter (body : fun_body) : VarId.generator = + (* Find the max id in the input variables - some of them may have been + * filtered from the body *) + let min_input_id = + List.fold_left + (fun id (var : var) -> VarId.max id var.id) + VarId.zero body.inputs + in + let obj = + object + inherit [_] reduce_expression + method zero _ = min_input_id + method plus id0 id1 _ = VarId.max (id0 ()) (id1 ()) + (* Get the maximum *) + + (** For the patterns *) + method! visit_var _ v _ = v.id + + (** For the rvalues *) + method! visit_Var _ vid _ = vid + end + in + (* Find the max counter in the body *) + let id = obj#visit_expression () body.body.e () in + VarId.generator_from_incr_id id + +(** "pretty-name context": see [compute_pretty_names] *) +type pn_ctx = { + pure_vars : string VarId.Map.t; + (** Information about the pure variables used in the synthesized program *) + llbc_vars : string V.VarId.Map.t; + (** Information about the LLBC variables used in the original program *) +} + +(** This function computes pretty names for the variables in the pure AST. It + relies on the "meta"-place information in the AST to generate naming + constraints, and then uses those to compute the names. + + The way it works is as follows: + - we only modify the names of the unnamed variables + - whenever we see an rvalue/pattern which is exactly an unnamed variable, + and this value is linked to some meta-place information which contains + a name and an empty path, we consider we should use this name + - we try to propagate naming constraints on the pure variables use in the + synthesized programs, and also on the LLBC variables from the original + program (information about the LLBC variables is stored in the meta-places) + + + Something important is that, for every variable we find, the name of this + variable can be influenced by the information we find *below* in the AST. + + For instance, the following situations happen: + + - let's say we evaluate: + {[ + match (ls : List<T>) { + List::Cons(x, hd) => { + ... + } + } + ]} + + Actually, in MIR, we get: + {[ + tmp := discriminant(ls); + switch tmp { + 0 => { + x := (ls as Cons).0; // (i) + hd := (ls as Cons).1; // (ii) + ... + } + } + ]} + If [ls] maps to a symbolic value [s0] upon evaluating the match in symbolic + mode, we expand this value upon evaluating [tmp = discriminant(ls)]. + However, at this point, we don't know which should be the names of + the symbolic values we introduce for the fields of [Cons]! + + Let's imagine we have (for the [Cons] branch): [s0 ~~> Cons s1 s2]. + The assigments at (i) and (ii) lead to the following binding in the + evaluation context: + {[ + x -> s1 + hd -> s2 + ]} + + When generating the symbolic AST, we save as meta-information that we + assign [s1] to the place [x] and [s2] to the place [hd]. This way, + we learn we can use the names [x] and [hd] for the variables which are + introduced by the match: + {[ + match ls with + | Cons x hd -> ... + | ... + ]} + - Assignments: + [let x [@mplace=lp] = v [@mplace = rp] in ...] + + We propagate naming information across the assignments. This is important + because many reassignments using temporary, anonymous variables are + introduced during desugaring. + + - Given back values (introduced by backward functions): + Let's say we have the following Rust code: + {[ + let py = id(&mut x); + *py = 2; + assert!(x == 2); + ]} + + After desugaring, we get the following MIR: + {[ + ^0 = &mut x; // anonymous variable + py = id(move ^0); + *py += 2; + assert!(x == 2); + ]} + + We want this to be translated as: + {[ + let py = id_fwd x in + let py1 = py + 2 in + let x1 = id_back x py1 in // <-- x1 is "given back": doesn't appear in the original MIR + assert(x1 = 2); + ]} + + We want to notice that the value given back by [id_back] is given back for "x", + so we should use "x" as the basename (hence the resulting name "x1"). However, + this is non-trivial, because after desugaring the input argument given to [id] + is not [&mut x] but [move ^0] (i.e., it comes from a temporary, anonymous + variable). For this reason, we use the meta-place [&mut x] as the meta-place + for the given back value (this is done during the synthesis), and propagate + naming information *also* on the LLBC variables (which are referenced by the + meta-places). + + This way, because of [^0 = &mut x], we can propagate the name "x" to the place + [^0], then to the given back variable across the function call. + + *) +let compute_pretty_names (def : fun_decl) : fun_decl = + (* Small helpers *) + (* + * When we do branchings, we need to merge (the constraints saved in) the + * contexts returned by the different branches. + * + * Note that by doing so, some mappings from var id to name + * in one context may be overriden by the ones in the other context. + * + * This should be ok because: + * - generally, the overriden variables should have been introduced *inside* + * the branches, in which case we don't care + * - or they were introduced before, in which case the naming should generally + * be consistent? In the worse case, it isn't, but it leads only to less + * readable code, not to unsoundness. This case should be pretty rare, + * also. + *) + let merge_ctxs (ctx0 : pn_ctx) (ctx1 : pn_ctx) : pn_ctx = + let pure_vars = + VarId.Map.fold + (fun id name ctx -> VarId.Map.add id name ctx) + ctx0.pure_vars ctx1.pure_vars + in + let llbc_vars = + V.VarId.Map.fold + (fun id name ctx -> V.VarId.Map.add id name ctx) + ctx0.llbc_vars ctx1.llbc_vars + in + { pure_vars; llbc_vars } + in + let empty_ctx = + { pure_vars = VarId.Map.empty; llbc_vars = V.VarId.Map.empty } + in + let merge_ctxs_ls (ctxs : pn_ctx list) : pn_ctx = + List.fold_left (fun ctx0 ctx1 -> merge_ctxs ctx0 ctx1) empty_ctx ctxs + in + + (* + * The way we do is as follows: + * - we explore the expressions + * - we register the variables introduced by the let-bindings + * - we use the naming information we find (through the variables and the + * meta-places) to update our context (i.e., maps from variable ids to + * names) + * - we use this information to update the names of the variables used in the + * expressions + *) + + (* Register a variable for constraints propagation - used when an variable is + * introduced (left-hand side of a left binding) *) + let register_var (ctx : pn_ctx) (v : var) : pn_ctx = + assert (not (VarId.Map.mem v.id ctx.pure_vars)); + match v.basename with + | None -> ctx + | Some name -> + let pure_vars = VarId.Map.add v.id name ctx.pure_vars in + { ctx with pure_vars } + in + (* Update a variable - used to update an expression after we computed constraints *) + let update_var (ctx : pn_ctx) (v : var) (mp : mplace option) : var = + match v.basename with + | Some _ -> v + | None -> ( + match VarId.Map.find_opt v.id ctx.pure_vars with + | Some basename -> { v with basename = Some basename } + | None -> + if Option.is_some mp then + match + V.VarId.Map.find_opt (Option.get mp).var_id ctx.llbc_vars + with + | None -> v + | Some basename -> { v with basename = Some basename } + else v) + in + (* Update an pattern - used to update an expression after we computed constraints *) + let update_typed_pattern ctx (lv : typed_pattern) : typed_pattern = + let obj = + object + inherit [_] map_typed_pattern + method! visit_PatVar _ v mp = PatVar (update_var ctx v mp, mp) + end + in + obj#visit_typed_pattern () lv + in + + (* Register an mplace the first time we find one *) + let register_mplace (mp : mplace) (ctx : pn_ctx) : pn_ctx = + match (V.VarId.Map.find_opt mp.var_id ctx.llbc_vars, mp.name) with + | None, Some name -> + let llbc_vars = V.VarId.Map.add mp.var_id name ctx.llbc_vars in + { ctx with llbc_vars } + | _ -> ctx + in + + (* Register the fact that [name] can be used for the pure variable identified + * by [var_id] (will add this name in the map if the variable is anonymous) *) + let add_pure_var_constraint (var_id : VarId.id) (name : string) (ctx : pn_ctx) + : pn_ctx = + let pure_vars = + if VarId.Map.mem var_id ctx.pure_vars then ctx.pure_vars + else VarId.Map.add var_id name ctx.pure_vars + in + { ctx with pure_vars } + in + (* Similar to [add_pure_var_constraint], but for LLBC variables *) + let add_llbc_var_constraint (var_id : V.VarId.id) (name : string) + (ctx : pn_ctx) : pn_ctx = + let llbc_vars = + if V.VarId.Map.mem var_id ctx.llbc_vars then ctx.llbc_vars + else V.VarId.Map.add var_id name ctx.llbc_vars + in + { ctx with llbc_vars } + in + (* Add a constraint: given a variable id and an associated meta-place, try to + * extract naming information from the meta-place and save it *) + let add_constraint (mp : mplace) (var_id : VarId.id) (ctx : pn_ctx) : pn_ctx = + (* Register the place *) + let ctx = register_mplace mp ctx in + (* Update the variable name *) + match (mp.name, mp.projection) with + | Some name, [] -> + (* Check if the variable already has a name - if not: insert the new name *) + let ctx = add_pure_var_constraint var_id name ctx in + let ctx = add_llbc_var_constraint mp.var_id name ctx in + ctx + | _ -> ctx + in + (* Specific case of constraint on rvalues *) + let add_right_constraint (mp : mplace) (rv : texpression) (ctx : pn_ctx) : + pn_ctx = + (* Register the place *) + let ctx = register_mplace mp ctx in + (* Add the constraint *) + match (unmeta rv).e with Var vid -> add_constraint mp vid ctx | _ -> ctx + in + (* Specific case of constraint on left values *) + let add_left_constraint (lv : typed_pattern) (ctx : pn_ctx) : pn_ctx = + let obj = + object (self) + inherit [_] reduce_typed_pattern + method zero _ = empty_ctx + method plus ctx0 ctx1 _ = merge_ctxs (ctx0 ()) (ctx1 ()) + + method! visit_PatVar _ v mp () = + (* Register the variable *) + let ctx = register_var (self#zero ()) v in + (* Register the mplace information if there is such information *) + match mp with Some mp -> add_constraint mp v.id ctx | None -> ctx + end + in + let ctx1 = obj#visit_typed_pattern () lv () in + merge_ctxs ctx ctx1 + in + + (* This is used to propagate constraint information about places in case of + * variable reassignments: we try to propagate the information from the + * rvalue to the left *) + let add_left_right_constraint (lv : typed_pattern) (re : texpression) + (ctx : pn_ctx) : pn_ctx = + (* We propagate constraints across variable reassignments: [^0 = x], + * if the destination doesn't have naming information *) + match lv.value with + | PatVar (({ id = _; basename = None; ty = _ } as lvar), lmp) -> + if + (* Check that there is not already a name for the variable *) + VarId.Map.mem lvar.id ctx.pure_vars + then ctx + else + (* We ignore the left meta-place information: it should have been taken + * care of by [add_left_constraint]. We try to use the right meta-place + * information *) + let add (name : string) (ctx : pn_ctx) : pn_ctx = + (* Add the constraint for the pure variable *) + let ctx = add_pure_var_constraint lvar.id name ctx in + (* Add the constraint for the LLBC variable *) + match lmp with + | None -> ctx + | Some lmp -> add_llbc_var_constraint lmp.var_id name ctx + in + (* We try to use the right-place information *) + let rmp, re = opt_unmeta_mplace re in + let ctx = + match rmp with + | Some { var_id; name; projection = [] } -> ( + if Option.is_some name then add (Option.get name) ctx + else + match V.VarId.Map.find_opt var_id ctx.llbc_vars with + | None -> ctx + | Some name -> add name ctx) + | _ -> ctx + in + (* We try to use the rvalue information, if it is a variable *) + let ctx = + match (unmeta re).e with + | Var rvar_id -> ( + match VarId.Map.find_opt rvar_id ctx.pure_vars with + | None -> ctx + | Some name -> add name ctx) + | _ -> ctx + in + ctx + | _ -> ctx + in + + (* *) + let rec update_texpression (e : texpression) (ctx : pn_ctx) : + pn_ctx * texpression = + let ty = e.ty in + let ctx, e = + match e.e with + | Var _ -> (* Nothing to do *) (ctx, e.e) + | Const _ -> (* Nothing to do *) (ctx, e.e) + | App (app, arg) -> + let ctx, app = update_texpression app ctx in + let ctx, arg = update_texpression arg ctx in + let e = App (app, arg) in + (ctx, e) + | Abs (x, e) -> update_abs x e ctx + | Qualif _ -> (* nothing to do *) (ctx, e.e) + | Let (monadic, lb, re, e) -> update_let monadic lb re e ctx + | Switch (scrut, body) -> update_switch_body scrut body ctx + | Meta (meta, e) -> update_meta meta e ctx + in + (ctx, { e; ty }) + (* *) + and update_abs (x : typed_pattern) (e : texpression) (ctx : pn_ctx) : + pn_ctx * expression = + (* We first add the left-constraint *) + let ctx = add_left_constraint x ctx in + (* Update the expression, and add additional constraints *) + let ctx, e = update_texpression e ctx in + (* Update the abstracted value *) + let x = update_typed_pattern ctx x in + (* Put together *) + (ctx, Abs (x, e)) + (* *) + and update_let (monadic : bool) (lv : typed_pattern) (re : texpression) + (e : texpression) (ctx : pn_ctx) : pn_ctx * expression = + (* We first add the left-constraint *) + let ctx = add_left_constraint lv ctx in + (* Then we try to propagate the right-constraints to the left, in case + * the left constraints didn't give naming information *) + let ctx = add_left_right_constraint lv re ctx in + let ctx, re = update_texpression re ctx in + let ctx, e = update_texpression e ctx in + let lv = update_typed_pattern ctx lv in + (ctx, Let (monadic, lv, re, e)) + (* *) + and update_switch_body (scrut : texpression) (body : switch_body) + (ctx : pn_ctx) : pn_ctx * expression = + let ctx, scrut = update_texpression scrut ctx in + + let ctx, body = + match body with + | If (e_true, e_false) -> + let ctx1, e_true = update_texpression e_true ctx in + let ctx2, e_false = update_texpression e_false ctx in + let ctx = merge_ctxs ctx1 ctx2 in + (ctx, If (e_true, e_false)) + | Match branches -> + let ctx_branches_ls = + List.map + (fun br -> + let ctx = add_left_constraint br.pat ctx in + let ctx, branch = update_texpression br.branch ctx in + let pat = update_typed_pattern ctx br.pat in + (ctx, { pat; branch })) + branches + in + let ctxs, branches = List.split ctx_branches_ls in + let ctx = merge_ctxs_ls ctxs in + (ctx, Match branches) + in + (ctx, Switch (scrut, body)) + (* *) + and update_meta (meta : meta) (e : texpression) (ctx : pn_ctx) : + pn_ctx * expression = + let ctx = + match meta with + | Assignment (mp, rvalue, rmp) -> + let ctx = add_right_constraint mp rvalue ctx in + let ctx = + match (mp.projection, rmp) with + | [], Some { var_id; name; projection = [] } -> ( + let name = + match name with + | Some name -> Some name + | None -> V.VarId.Map.find_opt var_id ctx.llbc_vars + in + match name with + | None -> ctx + | Some name -> add_llbc_var_constraint mp.var_id name ctx) + | _ -> ctx + in + ctx + | MPlace mp -> add_right_constraint mp e ctx + in + let ctx, e = update_texpression e ctx in + let e = mk_meta meta e in + (ctx, e.e) + in + + let body = + match def.body with + | None -> None + | Some body -> + let input_names = + List.filter_map + (fun (v : var) -> + match v.basename with + | None -> None + | Some name -> Some (v.id, name)) + body.inputs + in + let ctx = + { + pure_vars = VarId.Map.of_list input_names; + llbc_vars = V.VarId.Map.empty; + } + in + let _, body_exp = update_texpression body.body ctx in + Some { body with body = body_exp } + in + { def with body } + +(** Remove the meta-information *) +let remove_meta (def : fun_decl) : fun_decl = + match def.body with + | None -> def + | Some body -> + let body = { body with body = PureUtils.remove_meta body.body } in + { def with body = Some body } + +(** Inline the useless variable (re-)assignments: + + A lot of intermediate variable assignments are introduced through the + compilation to MIR and by the translation itself (and the variable used + on the left is often unnamed). + + Note that many of them are just variable "reassignments": [let x = y in ...]. + Some others come from ?? + + TODO: how do we call that when we introduce intermediate variable assignments + for the arguments of a function call? + + [inline_named]: if [true], inline all the assignments of the form + [let VAR = VAR in ...], otherwise inline only the ones where the variable + on the left is anonymous. + + [inline_pure]: if [true], inline all the pure assignments where the variable + on the left is anonymous, but the assignments where the r-expression is + a non-primitive function call (i.e.: inline the binops, ADT constructions, + etc.). + + TODO: we have a smallish issue which is that rvalues should be merged with + expressions... For now, this forces us to substitute whenever we can, but + leave the let-bindings where they are, and eliminated them in a subsequent + pass (if they are useless). + *) +let inline_useless_var_reassignments (inline_named : bool) (inline_pure : bool) + (def : fun_decl) : fun_decl = + let obj = + object (self) + inherit [_] map_expression as super + + (** Visit the let-bindings to filter the useless ones (and update + the substitution map while doing so *) + method! visit_Let (env : texpression VarId.Map.t) monadic lv re e = + (* In order to filter, we need to check first that: + * - the let-binding is not monadic + * - the left-value is a variable + *) + match (monadic, lv.value) with + | false, PatVar (lv_var, _) -> + (* We can filter if: *) + (* 1. the left variable is unnamed or [inline_named] is true *) + let filter_left = + match (inline_named, lv_var.basename) with + | true, _ | _, None -> true + | _ -> false + in + (* And either: + * 2.1 the right-expression is a variable or a global *) + let var_or_global = is_var re || is_global re in + (* Or: + * 2.2 the right-expression is a constant value, an ADT value, + * a projection or a primitive function call *and* the flag + * [inline_pure] is set *) + let pure_re = + is_const re + || + let app, _ = destruct_apps re in + match app.e with + | Qualif qualif -> ( + match qualif.id with + | AdtCons _ -> true (* ADT constructor *) + | Proj _ -> true (* Projector *) + | Func (Unop _ | Binop _) -> + true (* primitive function call *) + | Func (Regular _) -> false (* non-primitive function call *) + | _ -> false) + | _ -> false + in + let filter = + filter_left && (var_or_global || (inline_pure && pure_re)) + in + + (* Update the rhs (we may perform substitutions inside, and it is + * better to do them *before* we inline it *) + let re = self#visit_texpression env re in + (* Update the substitution environment *) + let env = if filter then VarId.Map.add lv_var.id re env else env in + (* Update the next expression *) + let e = self#visit_texpression env e in + (* Reconstruct the [let], only if the binding is not filtered *) + if filter then e.e else Let (monadic, lv, re, e) + | _ -> super#visit_Let env monadic lv re e + + (** Substitute the variables *) + method! visit_Var (env : texpression VarId.Map.t) (vid : VarId.id) = + match VarId.Map.find_opt vid env with + | None -> (* No substitution *) super#visit_Var env vid + | Some ne -> + (* Substitute - note that we need to reexplore, because + * there may be stacked substitutions, if we have: + * var0 --> var1 + * var1 --> var2. + *) + self#visit_expression env ne.e + end + in + match def.body with + | None -> def + | Some body -> + let body = + { body with body = obj#visit_texpression VarId.Map.empty body.body } + in + { def with body = Some body } + +(** Given a forward or backward function call, is there, for every execution + path, a child backward function called later with exactly the same input + list prefix? We use this to filter useless function calls: if there are + such child calls, we can remove this one (in case its outputs are not + used). + We do this check because we can't simply remove function calls whose + outputs are not used, as they might fail. However, if a function fails, + its children backward functions then fail on the same inputs (ignoring + the additional inputs those receive). + + For instance, if we have: + {[ + fn f<'a>(x : &'a mut T); + ]} + + We often have things like this in the synthesized code: + {[ + _ <-- f x; + ... + nx <-- f@back'a x y; + ... + ]} + + In this situation, we can remove the call [f x]. + *) +let expression_contains_child_call_in_all_paths (ctx : trans_ctx) + (fun_id0 : fun_id) (tys0 : ty list) (args0 : texpression list) + (e : texpression) : bool = + let check_call (fun_id1 : fun_id) (tys1 : ty list) (args1 : texpression list) + : bool = + (* Check the fun_ids, to see if call1's function is a child of call0's function *) + match (fun_id0, fun_id1) with + | Regular (id0, rg_id0), Regular (id1, rg_id1) -> + (* Both are "regular" calls: check if they come from the same rust function *) + if id0 = id1 then + (* Same rust functions: check the regions hierarchy *) + let call1_is_child = + match (rg_id0, rg_id1) with + | None, _ -> + (* The function used in call0 is the forward function: the one + * used in call1 is necessarily a child *) + true + | Some _, None -> + (* Opposite of previous case *) + false + | Some rg_id0, Some rg_id1 -> + if rg_id0 = rg_id1 then true + else + (* We need to use the regions hierarchy *) + (* First, lookup the signature of the LLBC function *) + let sg = + LlbcAstUtils.lookup_fun_sig id0 ctx.fun_context.fun_decls + in + (* Compute the set of ancestors of the function in call1 *) + let call1_ancestors = + LlbcAstUtils.list_parent_region_groups sg rg_id1 + in + (* Check if the function used in call0 is inside *) + T.RegionGroupId.Set.mem rg_id0 call1_ancestors + in + (* If call1 is a child, then we need to check if the input arguments + * used in call0 are a prefix of the input arguments used in call1 + * (note call1 being a child, it will likely consume strictly more + * given back values). + * *) + if call1_is_child then + let call1_args = + Collections.List.prefix (List.length args0) args1 + in + let args = List.combine args0 call1_args in + (* Note that the input values are expressions, *which may contain + * meta-values* (which we need to ignore). *) + let input_eq (v0, v1) = + PureUtils.remove_meta v0 = PureUtils.remove_meta v1 + in + (* Compare the input types and the prefix of the input arguments *) + tys0 = tys1 && List.for_all input_eq args + else (* Not a child *) + false + else (* Not the same function *) + false + | _ -> false + in + + let visitor = + object (self) + inherit [_] reduce_expression + method zero _ = false + method plus b0 b1 _ = b0 () && b1 () + + method! visit_texpression env e = + match e.e with + | Var _ | Const _ -> fun _ -> false + | Let (_, _, re, e) -> ( + match opt_destruct_function_call re with + | None -> fun () -> self#visit_texpression env e () + | Some (func1, tys1, args1) -> + let call_is_child = check_call func1 tys1 args1 in + if call_is_child then fun () -> true + else fun () -> self#visit_texpression env e ()) + | App _ -> ( + fun () -> + match opt_destruct_function_call e with + | Some (func1, tys1, args1) -> check_call func1 tys1 args1 + | None -> false) + | Abs (_, e) -> self#visit_texpression env e + | Qualif _ -> + (* Note that this case includes functions without arguments *) + fun () -> false + | Meta (_, e) -> self#visit_texpression env e + | Switch (_, body) -> self#visit_switch_body env body + + method! visit_switch_body env body = + match body with + | If (e1, e2) -> + fun () -> + self#visit_texpression env e1 () + && self#visit_texpression env e2 () + | Match branches -> + fun () -> + List.for_all + (fun br -> self#visit_texpression env br.branch ()) + branches + end + in + visitor#visit_texpression () e () + +(** Filter the useless assignments (removes the useless variables, filters + the function calls) *) +let filter_useless (filter_monadic_calls : bool) (ctx : trans_ctx) + (def : fun_decl) : fun_decl = + (* We first need a transformation on *left-values*, which filters the useless + * variables and tells us whether the value contains any variable which has + * not been replaced by [_] (in which case we need to keep the assignment, + * etc.). + * + * This is implemented as a map-reduce. + * + * Returns: ( filtered_left_value, *all_dummies* ) + * + * [all_dummies]: + * If the returned boolean is true, it means that all the variables appearing + * in the filtered left-value are *dummies* (meaning that if this left-value + * appears at the left of a let-binding, this binding might potentially be + * removed). + *) + let lv_visitor = + object + inherit [_] mapreduce_typed_pattern + method zero _ = true + method plus b0 b1 _ = b0 () && b1 () + + method! visit_PatVar env v mp = + if VarId.Set.mem v.id env then (PatVar (v, mp), fun _ -> false) + else (PatDummy, fun _ -> true) + end + in + let filter_typed_pattern (used_vars : VarId.Set.t) (lv : typed_pattern) : + typed_pattern * bool = + let lv, all_dummies = lv_visitor#visit_typed_pattern used_vars lv in + (lv, all_dummies ()) + in + + (* We then implement the transformation on *expressions* through a mapreduce. + * Note that the transformation is bottom-up. + * The map filters the useless assignments, the reduce computes the set of + * used variables. + *) + let expr_visitor = + object (self) + inherit [_] mapreduce_expression as super + method zero _ = VarId.Set.empty + method plus s0 s1 _ = VarId.Set.union (s0 ()) (s1 ()) + + (** Whenever we visit a variable, we need to register the used variable *) + method! visit_Var _ vid = (Var vid, fun _ -> VarId.Set.singleton vid) + + method! visit_expression env e = + match e with + | Var _ | Const _ | App _ | Qualif _ + | Switch (_, _) + | Meta (_, _) + | Abs _ -> + super#visit_expression env e + | Let (monadic, lv, re, e) -> + (* Compute the set of values used in the next expression *) + let e, used = self#visit_texpression env e in + let used = used () in + (* Filter the left values *) + let lv, all_dummies = filter_typed_pattern used lv in + (* Small utility - called if we can't filter the let-binding *) + let dont_filter () = + let re, used_re = self#visit_texpression env re in + let used = VarId.Set.union used (used_re ()) in + (Let (monadic, lv, re, e), fun _ -> used) + in + (* Potentially filter the let-binding *) + if all_dummies then + if not monadic then + (* Not a monadic let-binding: simple case *) + (e.e, fun _ -> used) + else + (* Monadic let-binding: trickier. + * We can filter if the right-expression is a function call, + * under some conditions. *) + match (filter_monadic_calls, opt_destruct_function_call re) with + | true, Some (func, tys, args) -> + (* We need to check if there is a child call - see + * the comments for: + * [expression_contains_child_call_in_all_paths] *) + let has_child_call = + expression_contains_child_call_in_all_paths ctx func tys + args e + in + if has_child_call then (* Filter *) + (e.e, fun _ -> used) + else (* No child call: don't filter *) + dont_filter () + | _ -> + (* Not a call or not allowed to filter: we can't filter *) + dont_filter () + else (* There are used variables: don't filter *) + dont_filter () + end + in + (* We filter only inside of transparent (i.e., non-opaque) definitions *) + match def.body with + | None -> def + | Some body -> + (* Visit the body *) + let body_exp, used_vars = expr_visitor#visit_texpression () body.body in + (* Visit the parameters - TODO: update: we can filter only if the definition + * is not recursive (otherwise it might mess up with the decrease clauses: + * the decrease clauses uses all the inputs given to the function, if some + * inputs are replaced by '_' we can't give it to the function used in the + * decreases clause). + * For now we deactivate the filtering. *) + let used_vars = used_vars () in + let inputs_lvs = + if false then + List.map + (fun lv -> fst (filter_typed_pattern used_vars lv)) + body.inputs_lvs + else body.inputs_lvs + in + (* Return *) + let body = { body with body = body_exp; inputs_lvs } in + { def with body = Some body } + +(** Simplify the aggregated ADTs. + Ex.: + {[ + type struct = { f0 : nat; f1 : nat } + + Mkstruct x.f0 x.f1 ~~> x + ]} + + TODO: introduce a notation for [{ x with field = ... }], and use it. + *) +let simplify_aggregates (ctx : trans_ctx) (def : fun_decl) : fun_decl = + let expr_visitor = + object + inherit [_] map_expression as super + + (* Look for a type constructor applied to arguments *) + method! visit_texpression env e = + match e.e with + | App _ -> ( + let app, args = destruct_apps e in + match app.e with + | Qualif + { + id = AdtCons { adt_id = AdtId adt_id; variant_id = None }; + type_args; + } -> + (* This is a struct *) + (* Retrieve the definiton, to find how many fields there are *) + let adt_decl = + TypeDeclId.Map.find adt_id ctx.type_context.type_decls + in + let fields = + match adt_decl.kind with + | Enum _ | Opaque -> raise (Failure "Unreachable") + | Struct fields -> fields + in + let num_fields = List.length fields in + (* In order to simplify, there must be as many arguments as + * there are fields *) + assert (num_fields > 0); + if num_fields = List.length args then + (* We now need to check that all the arguments are of the form: + * [x.field] for some variable [x], and where the projection + * is for the proper ADT *) + let to_var_proj (i : int) (arg : texpression) : + (ty list * var_id) option = + match arg.e with + | App (proj, x) -> ( + match (proj.e, x.e) with + | ( Qualif + { + id = + Proj { adt_id = AdtId proj_adt_id; field_id }; + type_args = proj_type_args; + }, + Var v ) -> + (* We check that this is the proper ADT, and the proper field *) + if + proj_adt_id = adt_id + && FieldId.to_int field_id = i + then Some (proj_type_args, v) + else None + | _ -> None) + | _ -> None + in + let args = List.mapi to_var_proj args in + let args = List.filter_map (fun x -> x) args in + (* Check that all the arguments are of the expected form *) + if List.length args = num_fields then + (* Check that this is the same variable we project from - + * note that we checked above that there is at least one field *) + let (_, x), end_args = Collections.List.pop args in + if List.for_all (fun (_, y) -> y = x) end_args then ( + (* We can substitute *) + (* Sanity check: all types correct *) + assert ( + List.for_all (fun (tys, _) -> tys = type_args) args); + { e with e = Var x }) + else super#visit_texpression env e + else super#visit_texpression env e + else super#visit_texpression env e + | _ -> super#visit_texpression env e) + | _ -> super#visit_texpression env e + end + in + match def.body with + | None -> def + | Some body -> + (* Visit the body *) + let body_exp = expr_visitor#visit_texpression () body.body in + (* Return *) + let body = { body with body = body_exp } in + { def with body = Some body } + +(** Return [None] if the function is a backward function with no outputs (so + that we eliminate the definition which is useless). + + Note that the calls to such functions are filtered when translating from + symbolic to pure. Here, we remove the definitions altogether, because they + are now useless + *) +let filter_if_backward_with_no_outputs (config : config) (def : fun_decl) : + fun_decl option = + if + config.filter_useless_functions && Option.is_some def.back_id + && def.signature.output = mk_result_ty mk_unit_ty + then None + else Some def + +(** Return [false] if the forward function is useless and should be filtered. + + - a forward function with no output (comes from a Rust function with + unit return type) + - the function has mutable borrows as inputs (which is materialized + by the fact we generated backward functions which were not filtered). + + In such situation, every call to the Rust function will be translated to: + - a call to the forward function which returns nothing + - calls to the backward functions + As a failing backward function implies the forward function also fails, + we can filter the calls to the forward function, which thus becomes + useless. + In such situation, we can remove the forward function definition + altogether. + *) +let keep_forward (config : config) (trans : pure_fun_translation) : bool = + let fwd, backs = trans in + (* Note that at this point, the output types are no longer seen as tuples: + * they should be lists of length 1. *) + if + config.filter_useless_functions + && fwd.signature.output = mk_result_ty mk_unit_ty + && backs <> [] + then false + else true + +(** Convert the unit variables to [()] if they are used as right-values or + [_] if they are used as left values in patterns. *) +let unit_vars_to_unit (def : fun_decl) : fun_decl = + (* The map visitor *) + let obj = + object + inherit [_] map_expression as super + + (** Replace in patterns *) + method! visit_PatVar _ v mp = + if v.ty = mk_unit_ty then PatDummy else PatVar (v, mp) + + (** Replace in "regular" expressions - note that we could limit ourselves + to variables, but this is more powerful + *) + method! visit_texpression env e = + if e.ty = mk_unit_ty then mk_unit_rvalue + else super#visit_texpression env e + end + in + (* Update the body *) + match def.body with + | None -> def + | Some body -> + let body_exp = obj#visit_texpression () body.body in + (* Update the input parameters *) + let inputs_lvs = List.map (obj#visit_typed_pattern ()) body.inputs_lvs in + (* Return *) + let body = Some { body with body = body_exp; inputs_lvs } in + { def with body } + +(** Eliminate the box functions like [Box::new], [Box::deref], etc. Most of them + are translated to identity, and [Box::free] is translated to [()]. + + Note that the box types have already been eliminated during the translation + from symbolic to pure. + The reason why we don't eliminate the box functions at the same time is + that we would need to eliminate them in two different places: when translating + function calls, and when translating end abstractions. Here, we can do + something simpler, in one micro-pass. + *) +let eliminate_box_functions (_ctx : trans_ctx) (def : fun_decl) : fun_decl = + (* The map visitor *) + let obj = + object + inherit [_] map_expression as super + + method! visit_texpression env e = + match opt_destruct_function_call e with + | Some (fun_id, _tys, args) -> ( + match fun_id with + | Regular (A.Assumed aid, rg_id) -> ( + (* Below, when dealing with the arguments: we consider the very + * general case, where functions could be boxed (meaning we + * could have: [box_new f x]) + * *) + match (aid, rg_id) with + | A.BoxNew, _ -> + assert (rg_id = None); + let arg, args = Collections.List.pop args in + mk_apps arg args + | A.BoxDeref, None -> + (* [Box::deref] forward is the identity *) + let arg, args = Collections.List.pop args in + mk_apps arg args + | A.BoxDeref, Some _ -> + (* [Box::deref] backward is [()] (doesn't give back anything) *) + assert (args = []); + mk_unit_rvalue + | A.BoxDerefMut, None -> + (* [Box::deref_mut] forward is the identity *) + let arg, args = Collections.List.pop args in + mk_apps arg args + | A.BoxDerefMut, Some _ -> + (* [Box::deref_mut] back is almost the identity: + * let box_deref_mut (x_init : t) (x_back : t) : t = x_back + * *) + let arg, args = + match args with + | _ :: given_back :: args -> (given_back, args) + | _ -> failwith "Unreachable" + in + mk_apps arg args + | A.BoxFree, _ -> + assert (args = []); + mk_unit_rvalue + | ( ( A.Replace | A.VecNew | A.VecPush | A.VecInsert | A.VecLen + | A.VecIndex | A.VecIndexMut ), + _ ) -> + super#visit_texpression env e) + | _ -> super#visit_texpression env e) + | _ -> super#visit_texpression env e + end + in + (* Update the body *) + match def.body with + | None -> def + | Some body -> + let body = Some { body with body = obj#visit_texpression () body.body } in + { def with body } + +(** Decompose the monadic let-bindings. + + See the explanations in [config]. + *) +let decompose_monadic_let_bindings (_ctx : trans_ctx) (def : fun_decl) : + fun_decl = + match def.body with + | None -> def + | Some body -> + (* Set up the var id generator *) + let cnt = get_body_min_var_counter body in + let _, fresh_id = VarId.mk_stateful_generator cnt in + (* It is a very simple map *) + let obj = + object (self) + inherit [_] map_expression as super + + method! visit_Let env monadic lv re next_e = + if not monadic then super#visit_Let env monadic lv re next_e + else + (* If monadic, we need to check if the left-value is a variable: + * - if yes, don't decompose + * - if not, make the decomposition in two steps + *) + match lv.value with + | PatVar _ -> + (* Variable: nothing to do *) + super#visit_Let env monadic lv re next_e + | _ -> + (* Not a variable: decompose *) + (* Introduce a temporary variable to receive the value of the + * monadic binding *) + let vid = fresh_id () in + let tmp : var = { id = vid; basename = None; ty = lv.ty } in + let ltmp = mk_typed_pattern_from_var tmp None in + let rtmp = mk_texpression_from_var tmp in + (* Visit the next expression *) + let next_e = self#visit_texpression env next_e in + (* Create the let-bindings *) + (mk_let true ltmp re (mk_let false lv rtmp next_e)).e + end + in + (* Update the body *) + let body = Some { body with body = obj#visit_texpression () body.body } in + (* Return *) + { def with body } + +(** Unfold the monadic let-bindings to explicit matches. *) +let unfold_monadic_let_bindings (_ctx : trans_ctx) (def : fun_decl) : fun_decl = + match def.body with + | None -> def + | Some body -> + (* It is a very simple map *) + let obj = + object (_self) + inherit [_] map_expression as super + + method! visit_Let env monadic lv re e = + (* We simply do the following transformation: + {[ + pat <-- re; e + + ~~> + + match re with + | Fail err -> Fail err + | Return pat -> e + ]} + *) + (* TODO: we should use a monad "kind" instead of a boolean *) + if not monadic then super#visit_Let env monadic lv re e + else + (* We don't do the same thing if we use a state-error monad or simply + an error monad. + Note that some functions always live in the error monad (arithmetic + operations, for instance). + *) + (* TODO: this information should be computed in SymbolicToPure and + * store in an enum ("monadic" should be an enum, not a bool). *) + let re_ty = Option.get (opt_destruct_result re.ty) in + assert (lv.ty = re_ty); + let fail_pat = mk_result_fail_pattern lv.ty in + let fail_value = mk_result_fail_texpression e.ty in + let fail_branch = { pat = fail_pat; branch = fail_value } in + let success_pat = mk_result_return_pattern lv in + let success_branch = { pat = success_pat; branch = e } in + let switch_body = Match [ fail_branch; success_branch ] in + let e = Switch (re, switch_body) in + (* Continue *) + super#visit_expression env e + end + in + (* Update the body *) + let body_e = obj#visit_texpression () body.body in + let body = { body with body = body_e } in + (* Return *) + { def with body = Some body } + +(** Apply all the micro-passes to a function. + + Will return [None] if the function is a backward function with no outputs. + + [ctx]: used only for printing. + *) +let apply_passes_to_def (config : config) (ctx : trans_ctx) (def : fun_decl) : + fun_decl option = + (* Debug *) + log#ldebug + (lazy + ("PureMicroPasses.apply_passes_to_def: " + ^ Print.fun_name_to_string def.basename + ^ " (" + ^ Print.option_to_string T.RegionGroupId.to_string def.back_id + ^ ")")); + + (* First, find names for the variables which are unnamed *) + let def = compute_pretty_names def in + log#ldebug + (lazy ("compute_pretty_name:\n\n" ^ fun_decl_to_string ctx def ^ "\n")); + + (* TODO: we might want to leverage more the assignment meta-data, for + * aggregates for instance. *) + + (* TODO: reorder the branches of the matches/switches *) + + (* The meta-information is now useless: remove it. + * Rk.: some passes below use the fact that we removed the meta-data + * (otherwise we would have to "unmeta" expressions before matching) *) + let def = remove_meta def in + log#ldebug (lazy ("remove_meta:\n\n" ^ fun_decl_to_string ctx def ^ "\n")); + + (* Remove the backward functions with no outputs. + * Note that the calls to those functions should already have been removed, + * when translating from symbolic to pure. Here, we remove the definitions + * altogether, because they are now useless *) + let def = filter_if_backward_with_no_outputs config def in + + match def with + | None -> None + | Some def -> + (* Convert the unit variables to [()] if they are used as right-values or + * [_] if they are used as left values. *) + let def = unit_vars_to_unit def in + log#ldebug + (lazy ("unit_vars_to_unit:\n\n" ^ fun_decl_to_string ctx def ^ "\n")); + + (* Inline the useless variable reassignments *) + let inline_named_vars = true in + let inline_pure = true in + let def = + inline_useless_var_reassignments inline_named_vars inline_pure def + in + log#ldebug + (lazy + ("inline_useless_var_assignments:\n\n" ^ fun_decl_to_string ctx def + ^ "\n")); + + (* Eliminate the box functions - note that the "box" types were eliminated + * during the symbolic to pure phase: see the comments for [eliminate_box_functions] *) + let def = eliminate_box_functions ctx def in + log#ldebug + (lazy + ("eliminate_box_functions:\n\n" ^ fun_decl_to_string ctx def ^ "\n")); + + (* Filter the useless variables, assignments, function calls, etc. *) + let def = filter_useless config.filter_useless_monadic_calls ctx def in + log#ldebug + (lazy ("filter_useless:\n\n" ^ fun_decl_to_string ctx def ^ "\n")); + + (* Simplify the aggregated ADTs. + Ex.: + {[ + type struct = { f0 : nat; f1 : nat } + + Mkstruct x.f0 x.f1 ~~> x + ]} + *) + let def = simplify_aggregates ctx def in + log#ldebug + (lazy ("simplify_aggregates:\n\n" ^ fun_decl_to_string ctx def ^ "\n")); + + (* Decompose the monadic let-bindings - F* specific + * TODO: remove? *) + let def = + if config.decompose_monadic_let_bindings then ( + let def = decompose_monadic_let_bindings ctx def in + log#ldebug + (lazy + ("decompose_monadic_let_bindings:\n\n" + ^ fun_decl_to_string ctx def ^ "\n")); + def) + else ( + log#ldebug + (lazy + "ignoring decompose_monadic_let_bindings due to the configuration\n"); + def) + in + + (* Unfold the monadic let-bindings *) + let def = + if config.unfold_monadic_let_bindings then ( + let def = unfold_monadic_let_bindings ctx def in + log#ldebug + (lazy + ("unfold_monadic_let_bindings:\n\n" ^ fun_decl_to_string ctx def + ^ "\n")); + def) + else ( + log#ldebug + (lazy + "ignoring unfold_monadic_let_bindings due to the configuration\n"); + def) + in + + (* We are done *) + Some def + +(** Return the forward/backward translations on which we applied the micro-passes. + + Also returns a boolean indicating whether the forward function should be kept + or not (because useful/useless - [true] means we need to keep the forward + function). + Note that we don't "filter" the forward function and return a boolean instead, + because this function contains useful information to extract the backward + functions: keeping it is not necessary but more convenient. + *) +let apply_passes_to_pure_fun_translation (config : config) (ctx : trans_ctx) + (trans : pure_fun_translation) : bool * pure_fun_translation = + (* Apply the passes to the individual functions *) + let forward, backwards = trans in + let forward = Option.get (apply_passes_to_def config ctx forward) in + let backwards = List.filter_map (apply_passes_to_def config ctx) backwards in + let trans = (forward, backwards) in + (* Compute whether we need to filter the forward function or not *) + (keep_forward config trans, trans) diff --git a/compiler/PureToExtract.ml b/compiler/PureToExtract.ml new file mode 100644 index 00000000..77c3afd4 --- /dev/null +++ b/compiler/PureToExtract.ml @@ -0,0 +1,723 @@ +(** This module is used to extract the pure ASTs to various theorem provers. + It defines utilities and helpers to make the work as easy as possible: + we try to factorize as much as possible the different extractions to the + backends we target. + *) + +open Pure +open TranslateCore +module C = Contexts +module RegionVarId = T.RegionVarId +module F = Format + +(** The local logger *) +let log = L.pure_to_extract_log + +type region_group_info = { + id : RegionGroupId.id; + (** The id of the region group. + Note that a simple way of generating unique names for backward + functions is to use the region group ids. + *) + region_names : string option list; + (** The names of the region variables included in this group. + Note that names are not always available... + *) +} + +module StringSet = Collections.MakeSet (Collections.OrderedString) +module StringMap = Collections.MakeMap (Collections.OrderedString) + +type name = Names.name +type type_name = Names.type_name +type global_name = Names.global_name +type fun_name = Names.fun_name + +(* TODO: this should a module we give to a functor! *) + +(** A formatter's role is twofold: + 1. Come up with name suggestions. + For instance, provided some information about a function (its basename, + information about the region group, etc.) it should come up with an + appropriate name for the forward/backward function. + + It can of course apply many transformations, like changing to camel case/ + snake case, adding prefixes/suffixes, etc. + + 2. Format some specific terms, like constants. + *) +type formatter = { + bool_name : string; + char_name : string; + int_name : integer_type -> string; + str_name : string; + field_name : name -> FieldId.id -> string option -> string; + (** Inputs: + - type name + - field id + - field name + + Note that fields don't always have names, but we still need to + generate some names if we want to extract the structures to records... + We might want to extract such structures to tuples, later, but field + access then causes trouble because not all provers accept syntax like + [x.3] where [x] is a tuple. + *) + variant_name : name -> string -> string; + (** Inputs: + - type name + - variant name + *) + struct_constructor : name -> string; + (** Structure constructors are used when constructing structure values. + + For instance, in F*: + {[ + type pair = { x : nat; y : nat } + let p : pair = Mkpair 0 1 + ]} + + Inputs: + - type name + *) + type_name : type_name -> string; + (** Provided a basename, compute a type name. *) + global_name : global_name -> string; + (** Provided a basename, compute a global name. *) + fun_name : + A.fun_id -> + fun_name -> + int -> + region_group_info option -> + bool * int -> + string; + (** Inputs: + - function id: this is especially useful to identify whether the + function is an assumed function or a local function + - function basename + - number of region groups + - region group information in case of a backward function + ([None] if forward function) + - pair: + - do we generate the forward function (it may have been filtered)? + - the number of extracted backward functions (not necessarily equal + to the number of region groups, because we may have filtered + some of them) + TODO: use the fun id for the assumed functions. + *) + decreases_clause_name : A.FunDeclId.id -> fun_name -> string; + (** Generates the name of the definition used to prove/reason about + termination. The generated code uses this clause where needed, + but its body must be defined by the user. + + Inputs: + - function id: this is especially useful to identify whether the + function is an assumed function or a local function + - function basename + *) + var_basename : StringSet.t -> string option -> ty -> string; + (** Generates a variable basename. + + Inputs: + - the set of names used in the context so far + - the basename we got from the symbolic execution, if we have one + - the type of the variable (can be useful for heuristics, in order + not to always use "x" for instance, whenever naming anonymous + variables) + + Note that once the formatter generated a basename, we add an index + if necessary to prevent name clashes: the burden of name clashes checks + is thus on the caller's side. + *) + type_var_basename : StringSet.t -> string -> string; + (** Generates a type variable basename. *) + append_index : string -> int -> string; + (** Appends an index to a name - we use this to generate unique + names: when doing so, the role of the formatter is just to concatenate + indices to names, the responsability of finding a proper index is + delegated to helper functions. + *) + extract_constant_value : F.formatter -> bool -> constant_value -> unit; + (** Format a constant value. + + Inputs: + - formatter + - [inside]: if [true], the value should be wrapped in parentheses + if it is made of an application (ex.: [U32 3]) + - the constant value + *) + extract_unop : + (bool -> texpression -> unit) -> + F.formatter -> + bool -> + unop -> + texpression -> + unit; + (** Format a unary operation + + Inputs: + - a formatter for expressions (called on the argument of the unop) + - extraction context (see below) + - formatter + - expression formatter + - [inside] + - unop + - argument + *) + extract_binop : + (bool -> texpression -> unit) -> + F.formatter -> + bool -> + E.binop -> + integer_type -> + texpression -> + texpression -> + unit; + (** Format a binary operation + + Inputs: + - a formatter for expressions (called on the arguments of the binop) + - extraction context (see below) + - formatter + - expression formatter + - [inside] + - binop + - argument 0 + - argument 1 + *) +} + +(** We use identifiers to look for name clashes *) +type id = + | GlobalId of A.GlobalDeclId.id + | FunId of A.fun_id * RegionGroupId.id option + | DecreasesClauseId of A.fun_id + (** The definition which provides the decreases/termination clause. + We insert calls to this clause to prove/reason about termination: + the body of those clauses must be defined by the user, in the + proper files. + *) + | TypeId of type_id + | StructId of type_id + (** We use this when we manipulate the names of the structure + constructors. + + For instance, in F*: + {[ + type pair = { x: nat; y : nat } + let p : pair = Mkpair 0 1 + ]} + *) + | VariantId of type_id * VariantId.id + (** If often happens that variant names must be unique (it is the case in + F* ) which is why we register them here. + *) + | FieldId of type_id * FieldId.id + (** If often happens that in the case of structures, the field names + must be unique (it is the case in F* ) which is why we register + them here. + *) + | TypeVarId of TypeVarId.id + | VarId of VarId.id + | UnknownId + (** Used for stored various strings like keywords, definitions which + should always be in context, etc. and which can't be linked to one + of the above. + *) +[@@deriving show, ord] + +module IdOrderedType = struct + type t = id + + let compare = compare_id + let to_string = show_id + let pp_t = pp_id + let show_t = show_id +end + +module IdMap = Collections.MakeMap (IdOrderedType) + +(** The names map stores the mappings from names to identifiers and vice-versa. + + We use it for lookups (during the translation) and to check for name clashes. + + [id_to_string] is for debugging. + *) +type names_map = { + id_to_name : string IdMap.t; + name_to_id : id StringMap.t; + (** The name to id map is used to look for name clashes, and generate nice + debugging messages: if there is a name clash, it is useful to know + precisely which identifiers are mapped to the same name... + *) + names_set : StringSet.t; +} + +let names_map_add (id_to_string : id -> string) (id : id) (name : string) + (nm : names_map) : names_map = + (* Check if there is a clash *) + (match StringMap.find_opt name nm.name_to_id with + | None -> () (* Ok *) + | Some clash -> + (* There is a clash: print a nice debugging message for the user *) + let id1 = "\n- " ^ id_to_string clash in + let id2 = "\n- " ^ id_to_string id in + let err = + "Name clash detected: the following identifiers are bound to the same \ + name \"" ^ name ^ "\":" ^ id1 ^ id2 + in + log#serror err; + failwith err); + (* Sanity check *) + assert (not (StringSet.mem name nm.names_set)); + (* Insert *) + let id_to_name = IdMap.add id name nm.id_to_name in + let name_to_id = StringMap.add name id nm.name_to_id in + let names_set = StringSet.add name nm.names_set in + { id_to_name; name_to_id; names_set } + +let names_map_add_assumed_type (id_to_string : id -> string) (id : assumed_ty) + (name : string) (nm : names_map) : names_map = + names_map_add id_to_string (TypeId (Assumed id)) name nm + +let names_map_add_assumed_struct (id_to_string : id -> string) (id : assumed_ty) + (name : string) (nm : names_map) : names_map = + names_map_add id_to_string (StructId (Assumed id)) name nm + +let names_map_add_assumed_variant (id_to_string : id -> string) + (id : assumed_ty) (variant_id : VariantId.id) (name : string) + (nm : names_map) : names_map = + names_map_add id_to_string (VariantId (Assumed id, variant_id)) name nm + +let names_map_add_assumed_function (id_to_string : id -> string) + (fid : A.assumed_fun_id) (rg_id : RegionGroupId.id option) (name : string) + (nm : names_map) : names_map = + names_map_add id_to_string (FunId (A.Assumed fid, rg_id)) name nm + +(** Make a (variable) basename unique (by adding an index). + + We do this in an inefficient manner (by testing all indices starting from + 0) but it shouldn't be a bottleneck. + + Also note that at some point, we thought about trying to reuse names of + variables which are not used anymore, like here: + {[ + let x = ... in + ... + let x0 = ... in // We could use the name "x" if [x] is not used below + ... + ]} + + However it is a good idea to keep things as they are for F*: as F* is + designed for extrinsic proofs, a proof about a function follows this + function's structure. The consequence is that we often end up + copy-pasting function bodies. As in the proofs (in assertions and + when calling lemmas) we often need to talk about the "past" (i.e., + previous values), it is very useful to generate code where all variable + names are assigned at most once. + + [append]: function to append an index to a string + *) +let basename_to_unique (names_set : StringSet.t) + (append : string -> int -> string) (basename : string) : string = + let rec gen (i : int) : string = + let s = append basename i in + if StringSet.mem s names_set then gen (i + 1) else s + in + if StringSet.mem basename names_set then gen 0 else basename + +(** Extraction context. + + Note that the extraction context contains information coming from the + LLBC AST (not only the pure AST). This is useful for naming, for instance: + we use the region information to generate the names of the backward + functions, etc. + *) +type extraction_ctx = { + trans_ctx : trans_ctx; + names_map : names_map; + fmt : formatter; + indent_incr : int; + (** The indent increment we insert whenever we need to indent more *) +} + +(** Debugging function *) +let id_to_string (id : id) (ctx : extraction_ctx) : string = + let global_decls = ctx.trans_ctx.global_context.global_decls in + let fun_decls = ctx.trans_ctx.fun_context.fun_decls in + let type_decls = ctx.trans_ctx.type_context.type_decls in + (* TODO: factorize the pretty-printing with what is in PrintPure *) + let get_type_name (id : type_id) : string = + match id with + | AdtId id -> + let def = TypeDeclId.Map.find id type_decls in + Print.name_to_string def.name + | Assumed aty -> show_assumed_ty aty + | Tuple -> failwith "Unreachable" + in + match id with + | GlobalId gid -> + let name = (A.GlobalDeclId.Map.find gid global_decls).name in + "global name: " ^ Print.global_name_to_string name + | FunId (fid, rg_id) -> + let fun_name = + match fid with + | A.Regular fid -> + Print.fun_name_to_string (A.FunDeclId.Map.find fid fun_decls).name + | A.Assumed aid -> A.show_assumed_fun_id aid + in + let fun_kind = + match rg_id with + | None -> "forward" + | Some rg_id -> "backward " ^ RegionGroupId.to_string rg_id + in + "fun name (" ^ fun_kind ^ "): " ^ fun_name + | DecreasesClauseId fid -> + let fun_name = + match fid with + | A.Regular fid -> + Print.fun_name_to_string (A.FunDeclId.Map.find fid fun_decls).name + | A.Assumed aid -> A.show_assumed_fun_id aid + in + "decreases clause for function: " ^ fun_name + | TypeId id -> "type name: " ^ get_type_name id + | StructId id -> "struct constructor of: " ^ get_type_name id + | VariantId (id, variant_id) -> + let variant_name = + match id with + | Tuple -> failwith "Unreachable" + | Assumed State -> failwith "Unreachable" + | Assumed Result -> + if variant_id = result_return_id then "@result::Return" + else if variant_id = result_fail_id then "@result::Fail" + else failwith "Unreachable" + | Assumed Option -> + if variant_id = option_some_id then "@option::Some" + else if variant_id = option_none_id then "@option::None" + else failwith "Unreachable" + | Assumed Vec -> failwith "Unreachable" + | AdtId id -> ( + let def = TypeDeclId.Map.find id type_decls in + match def.kind with + | Struct _ | Opaque -> failwith "Unreachable" + | Enum variants -> + let variant = VariantId.nth variants variant_id in + Print.name_to_string def.name ^ "::" ^ variant.variant_name) + in + "variant name: " ^ variant_name + | FieldId (id, field_id) -> + let field_name = + match id with + | Tuple -> failwith "Unreachable" + | Assumed (State | Result | Option) -> failwith "Unreachable" + | Assumed Vec -> + (* We can't directly have access to the fields of a vector *) + failwith "Unreachable" + | AdtId id -> ( + let def = TypeDeclId.Map.find id type_decls in + match def.kind with + | Enum _ | Opaque -> failwith "Unreachable" + | Struct fields -> + let field = FieldId.nth fields field_id in + let field_name = + match field.field_name with + | None -> FieldId.to_string field_id + | Some name -> name + in + Print.name_to_string def.name ^ "." ^ field_name) + in + "field name: " ^ field_name + | UnknownId -> "keyword" + | TypeVarId _ | VarId _ -> + (* We should never get there: we add indices to make sure variable + * names are unique *) + failwith "Unreachable" + +let ctx_add (id : id) (name : string) (ctx : extraction_ctx) : extraction_ctx = + (* The id_to_string function to print nice debugging messages if there are + * collisions *) + let id_to_string (id : id) : string = id_to_string id ctx in + let names_map = names_map_add id_to_string id name ctx.names_map in + { ctx with names_map } + +let ctx_get (id : id) (ctx : extraction_ctx) : string = + match IdMap.find_opt id ctx.names_map.id_to_name with + | Some s -> s + | None -> + log#serror ("Could not find: " ^ id_to_string id ctx); + raise Not_found + +let ctx_get_global (id : A.GlobalDeclId.id) (ctx : extraction_ctx) : string = + ctx_get (GlobalId id) ctx + +let ctx_get_function (id : A.fun_id) (rg : RegionGroupId.id option) + (ctx : extraction_ctx) : string = + ctx_get (FunId (id, rg)) ctx + +let ctx_get_local_function (id : A.FunDeclId.id) (rg : RegionGroupId.id option) + (ctx : extraction_ctx) : string = + ctx_get_function (A.Regular id) rg ctx + +let ctx_get_type (id : type_id) (ctx : extraction_ctx) : string = + assert (id <> Tuple); + ctx_get (TypeId id) ctx + +let ctx_get_local_type (id : TypeDeclId.id) (ctx : extraction_ctx) : string = + ctx_get_type (AdtId id) ctx + +let ctx_get_assumed_type (id : assumed_ty) (ctx : extraction_ctx) : string = + ctx_get_type (Assumed id) ctx + +let ctx_get_var (id : VarId.id) (ctx : extraction_ctx) : string = + ctx_get (VarId id) ctx + +let ctx_get_type_var (id : TypeVarId.id) (ctx : extraction_ctx) : string = + ctx_get (TypeVarId id) ctx + +let ctx_get_field (type_id : type_id) (field_id : FieldId.id) + (ctx : extraction_ctx) : string = + ctx_get (FieldId (type_id, field_id)) ctx + +let ctx_get_struct (def_id : type_id) (ctx : extraction_ctx) : string = + ctx_get (StructId def_id) ctx + +let ctx_get_variant (def_id : type_id) (variant_id : VariantId.id) + (ctx : extraction_ctx) : string = + ctx_get (VariantId (def_id, variant_id)) ctx + +let ctx_get_decreases_clause (def_id : A.FunDeclId.id) (ctx : extraction_ctx) : + string = + ctx_get (DecreasesClauseId (A.Regular def_id)) ctx + +(** Generate a unique type variable name and add it to the context *) +let ctx_add_type_var (basename : string) (id : TypeVarId.id) + (ctx : extraction_ctx) : extraction_ctx * string = + let name = ctx.fmt.type_var_basename ctx.names_map.names_set basename in + let name = + basename_to_unique ctx.names_map.names_set ctx.fmt.append_index name + in + let ctx = ctx_add (TypeVarId id) name ctx in + (ctx, name) + +(** See {!ctx_add_type_var} *) +let ctx_add_type_vars (vars : (string * TypeVarId.id) list) + (ctx : extraction_ctx) : extraction_ctx * string list = + List.fold_left_map + (fun ctx (name, id) -> ctx_add_type_var name id ctx) + ctx vars + +(** Generate a unique variable name and add it to the context *) +let ctx_add_var (basename : string) (id : VarId.id) (ctx : extraction_ctx) : + extraction_ctx * string = + let name = + basename_to_unique ctx.names_map.names_set ctx.fmt.append_index basename + in + let ctx = ctx_add (VarId id) name ctx in + (ctx, name) + +(** See {!ctx_add_var} *) +let ctx_add_vars (vars : var list) (ctx : extraction_ctx) : + extraction_ctx * string list = + List.fold_left_map + (fun ctx (v : var) -> + let name = ctx.fmt.var_basename ctx.names_map.names_set v.basename v.ty in + ctx_add_var name v.id ctx) + ctx vars + +let ctx_add_type_params (vars : type_var list) (ctx : extraction_ctx) : + extraction_ctx * string list = + List.fold_left_map + (fun ctx (var : type_var) -> ctx_add_type_var var.name var.index ctx) + ctx vars + +let ctx_add_type_decl_struct (def : type_decl) (ctx : extraction_ctx) : + extraction_ctx * string = + let cons_name = ctx.fmt.struct_constructor def.name in + let ctx = ctx_add (StructId (AdtId def.def_id)) cons_name ctx in + (ctx, cons_name) + +let ctx_add_type_decl (def : type_decl) (ctx : extraction_ctx) : extraction_ctx + = + let def_name = ctx.fmt.type_name def.name in + let ctx = ctx_add (TypeId (AdtId def.def_id)) def_name ctx in + ctx + +let ctx_add_field (def : type_decl) (field_id : FieldId.id) (field : field) + (ctx : extraction_ctx) : extraction_ctx * string = + let name = ctx.fmt.field_name def.name field_id field.field_name in + let ctx = ctx_add (FieldId (AdtId def.def_id, field_id)) name ctx in + (ctx, name) + +let ctx_add_fields (def : type_decl) (fields : (FieldId.id * field) list) + (ctx : extraction_ctx) : extraction_ctx * string list = + List.fold_left_map + (fun ctx (vid, v) -> ctx_add_field def vid v ctx) + ctx fields + +let ctx_add_variant (def : type_decl) (variant_id : VariantId.id) + (variant : variant) (ctx : extraction_ctx) : extraction_ctx * string = + let name = ctx.fmt.variant_name def.name variant.variant_name in + let ctx = ctx_add (VariantId (AdtId def.def_id, variant_id)) name ctx in + (ctx, name) + +let ctx_add_variants (def : type_decl) + (variants : (VariantId.id * variant) list) (ctx : extraction_ctx) : + extraction_ctx * string list = + List.fold_left_map + (fun ctx (vid, v) -> ctx_add_variant def vid v ctx) + ctx variants + +let ctx_add_struct (def : type_decl) (ctx : extraction_ctx) : + extraction_ctx * string = + let name = ctx.fmt.struct_constructor def.name in + let ctx = ctx_add (StructId (AdtId def.def_id)) name ctx in + (ctx, name) + +let ctx_add_decrases_clause (def : fun_decl) (ctx : extraction_ctx) : + extraction_ctx = + let name = ctx.fmt.decreases_clause_name def.def_id def.basename in + ctx_add (DecreasesClauseId (A.Regular def.def_id)) name ctx + +let ctx_add_global_decl_and_body (def : A.global_decl) (ctx : extraction_ctx) : + extraction_ctx = + let name = ctx.fmt.global_name def.name in + let decl = GlobalId def.def_id in + let body = FunId (Regular def.body_id, None) in + let ctx = ctx_add decl (name ^ "_c") ctx in + let ctx = ctx_add body (name ^ "_body") ctx in + ctx + +let ctx_add_fun_decl (trans_group : bool * pure_fun_translation) + (def : fun_decl) (ctx : extraction_ctx) : extraction_ctx = + (* Sanity check: the function should not be a global body - those are handled + * separately *) + assert (not def.is_global_decl_body); + (* Lookup the LLBC def to compute the region group information *) + let def_id = def.def_id in + let llbc_def = + A.FunDeclId.Map.find def_id ctx.trans_ctx.fun_context.fun_decls + in + let sg = llbc_def.signature in + let num_rgs = List.length sg.regions_hierarchy in + let keep_fwd, (_, backs) = trans_group in + let num_backs = List.length backs in + let rg_info = + match def.back_id with + | None -> None + | Some rg_id -> + let rg = T.RegionGroupId.nth sg.regions_hierarchy rg_id in + let regions = + List.map + (fun rid -> T.RegionVarId.nth sg.region_params rid) + rg.regions + in + let region_names = + List.map (fun (r : T.region_var) -> r.name) regions + in + Some { id = rg_id; region_names } + in + let def_id = A.Regular def_id in + let name = + ctx.fmt.fun_name def_id def.basename num_rgs rg_info (keep_fwd, num_backs) + in + ctx_add (FunId (def_id, def.back_id)) name ctx + +type names_map_init = { + keywords : string list; + assumed_adts : (assumed_ty * string) list; + assumed_structs : (assumed_ty * string) list; + assumed_variants : (assumed_ty * VariantId.id * string) list; + assumed_functions : (A.assumed_fun_id * RegionGroupId.id option * string) list; +} + +(** Initialize a names map with a proper set of keywords/names coming from the + target language/prover. *) +let initialize_names_map (init : names_map_init) : names_map = + let name_to_id = + StringMap.of_list (List.map (fun x -> (x, UnknownId)) init.keywords) + in + let names_set = StringSet.of_list init.keywords in + (* We fist initialize [id_to_name] as empty, because the id of a keyword is [UnknownId]. + * Also note that we don't need this mapping for keywords: we insert keywords only + * to check collisions. *) + let id_to_name = IdMap.empty in + let nm = { id_to_name; name_to_id; names_set } in + (* For debugging - we are creating bindings for assumed types and functions, so + * it is ok if we simply use the "show" function (those aren't simply identified + * by numbers) *) + let id_to_string = show_id in + (* Then we add: + * - the assumed types + * - the assumed struct constructors + * - the assumed variants + * - the assumed functions + *) + let nm = + List.fold_left + (fun nm (type_id, name) -> + names_map_add_assumed_type id_to_string type_id name nm) + nm init.assumed_adts + in + let nm = + List.fold_left + (fun nm (type_id, name) -> + names_map_add_assumed_struct id_to_string type_id name nm) + nm init.assumed_structs + in + let nm = + List.fold_left + (fun nm (type_id, variant_id, name) -> + names_map_add_assumed_variant id_to_string type_id variant_id name nm) + nm init.assumed_variants + in + let nm = + List.fold_left + (fun nm (fun_id, rg_id, name) -> + names_map_add_assumed_function id_to_string fun_id rg_id name nm) + nm init.assumed_functions + in + (* Return *) + nm + +let compute_type_decl_name (fmt : formatter) (def : type_decl) : string = + fmt.type_name def.name + +(** A helper function: generates a function suffix from a region group + information. + TODO: move all those helpers. +*) +let default_fun_suffix (num_region_groups : int) (rg : region_group_info option) + ((keep_fwd, num_backs) : bool * int) : string = + (* There are several cases: + - [rg] is [Some]: this is a forward function: + - we add "_fwd" + - [rg] is [None]: this is a backward function: + - this function has one extracted backward function: + - if the forward function has been filtered, we add "_fwd_back": + the forward function is useless, so the unique backward function + takes its place, in a way + - otherwise we add "_back" + - this function has several backward functions: we add "_back" and an + additional suffix to identify the precise backward function + Note that we always add a suffix (in case there are no region groups, + we could not add the "_fwd" suffix) to prevent name clashes between + definitions (in particular between type and function definitions). + *) + match rg with + | None -> "_fwd" + | Some rg -> + assert (num_region_groups > 0 && num_backs > 0); + if num_backs = 1 then + (* Exactly one backward function *) + if not keep_fwd then "_fwd_back" else "_back" + else if + (* Several region groups/backward functions: + - if all the regions in the group have names, we use those names + - otherwise we use an index + *) + List.for_all Option.is_some rg.region_names + then + (* Concatenate the region names *) + "_back" ^ String.concat "" (List.map Option.get rg.region_names) + else (* Use the region index *) + "_back" ^ RegionGroupId.to_string rg.id diff --git a/compiler/PureTypeCheck.ml b/compiler/PureTypeCheck.ml new file mode 100644 index 00000000..caad8a58 --- /dev/null +++ b/compiler/PureTypeCheck.ml @@ -0,0 +1,178 @@ +(** Module to perform type checking on the pure AST - we use this for sanity checks only *) + +open Pure +open PureUtils + +(** Utility function, used for type checking *) +let get_adt_field_types (type_decls : type_decl TypeDeclId.Map.t) + (type_id : type_id) (variant_id : VariantId.id option) (tys : ty list) : + ty list = + match type_id with + | Tuple -> + (* Tuple *) + assert (variant_id = None); + tys + | AdtId def_id -> + (* "Regular" ADT *) + let def = TypeDeclId.Map.find def_id type_decls in + type_decl_get_instantiated_fields_types def variant_id tys + | Assumed aty -> ( + (* Assumed type *) + match aty with + | State -> + (* [State] is opaque *) + raise (Failure "Unreachable: `State` values are opaque") + | Result -> + let ty = Collections.List.to_cons_nil tys in + let variant_id = Option.get variant_id in + if variant_id = result_return_id then [ ty ] + else if variant_id = result_fail_id then [] + else + raise (Failure "Unreachable: improper variant id for result type") + | Option -> + let ty = Collections.List.to_cons_nil tys in + let variant_id = Option.get variant_id in + if variant_id = option_some_id then [ ty ] + else if variant_id = option_none_id then [] + else + raise (Failure "Unreachable: improper variant id for result type") + | Vec -> raise (Failure "Unreachable: `Vector` values are opaque")) + +type tc_ctx = { + type_decls : type_decl TypeDeclId.Map.t; (** The type declarations *) + global_decls : A.global_decl A.GlobalDeclId.Map.t; + (** The global declarations *) + env : ty VarId.Map.t; (** Environment from variables to types *) +} + +let check_constant_value (v : constant_value) (ty : ty) : unit = + match (ty, v) with + | Integer int_ty, V.Scalar sv -> assert (int_ty = sv.V.int_ty) + | Bool, Bool _ | Char, Char _ | Str, String _ -> () + | _ -> raise (Failure "Inconsistent type") + +let rec check_typed_pattern (ctx : tc_ctx) (v : typed_pattern) : tc_ctx = + log#ldebug (lazy ("check_typed_pattern: " ^ show_typed_pattern v)); + match v.value with + | PatConcrete cv -> + check_constant_value cv v.ty; + ctx + | PatDummy -> ctx + | PatVar (var, _) -> + assert (var.ty = v.ty); + let env = VarId.Map.add var.id var.ty ctx.env in + { ctx with env } + | PatAdt av -> + (* Compute the field types *) + let type_id, tys = + match v.ty with + | Adt (type_id, tys) -> (type_id, tys) + | _ -> raise (Failure "Inconsistently typed value") + in + let field_tys = + get_adt_field_types ctx.type_decls type_id av.variant_id tys + in + let check_value (ctx : tc_ctx) (ty : ty) (v : typed_pattern) : tc_ctx = + if ty <> v.ty then ( + log#serror + ("check_typed_pattern: not the same types:" ^ "\n- ty: " + ^ show_ty ty ^ "\n- v.ty: " ^ show_ty v.ty); + raise (Failure "Inconsistent types")); + check_typed_pattern ctx v + in + (* Check the field types: check that the field patterns have the expected + * types, and check that the field patterns themselves are well-typed *) + List.fold_left + (fun ctx (ty, v) -> check_value ctx ty v) + ctx + (List.combine field_tys av.field_values) + +let rec check_texpression (ctx : tc_ctx) (e : texpression) : unit = + match e.e with + | Var var_id -> ( + (* Lookup the variable - note that the variable may not be there, + * if we type-check a subexpression (i.e.: if the variable is introduced + * "outside" of the expression) - TODO: this won't happen once + * we use a locally nameless representation *) + match VarId.Map.find_opt var_id ctx.env with + | None -> () + | Some ty -> assert (ty = e.ty)) + | Const cv -> check_constant_value cv e.ty + | App (app, arg) -> + let input_ty, output_ty = destruct_arrow app.ty in + assert (input_ty = arg.ty); + assert (output_ty = e.ty); + check_texpression ctx app; + check_texpression ctx arg + | Abs (pat, body) -> + let pat_ty, body_ty = destruct_arrow e.ty in + assert (pat.ty = pat_ty); + assert (body.ty = body_ty); + (* Check the pattern and register the introduced variables at the same time *) + let ctx = check_typed_pattern ctx pat in + check_texpression ctx body + | Qualif qualif -> ( + match qualif.id with + | Func _ -> () (* TODO *) + | Global _ -> () (* TODO *) + | Proj { adt_id = proj_adt_id; field_id } -> + (* Note we can only project fields of structures (not enumerations) *) + (* Deconstruct the projector type *) + let adt_ty, field_ty = destruct_arrow e.ty in + let adt_id, adt_type_args = + match adt_ty with + | Adt (type_id, tys) -> (type_id, tys) + | _ -> raise (Failure "Unreachable") + in + (* Check the ADT type *) + assert (adt_id = proj_adt_id); + assert (adt_type_args = qualif.type_args); + (* Retrieve and check the expected field type *) + let variant_id = None in + let expected_field_tys = + get_adt_field_types ctx.type_decls proj_adt_id variant_id + qualif.type_args + in + let expected_field_ty = FieldId.nth expected_field_tys field_id in + assert (expected_field_ty = field_ty) + | AdtCons id -> ( + let expected_field_tys = + get_adt_field_types ctx.type_decls id.adt_id id.variant_id + qualif.type_args + in + let field_tys, adt_ty = destruct_arrows e.ty in + assert (expected_field_tys = field_tys); + match adt_ty with + | Adt (type_id, tys) -> + assert (type_id = id.adt_id); + assert (tys = qualif.type_args) + | _ -> raise (Failure "Unreachable"))) + | Let (monadic, pat, re, e_next) -> + let expected_pat_ty = if monadic then destruct_result re.ty else re.ty in + assert (pat.ty = expected_pat_ty); + assert (e.ty = e_next.ty); + (* Check the right-expression *) + check_texpression ctx re; + (* Check the pattern and register the introduced variables at the same time *) + let ctx = check_typed_pattern ctx pat in + (* Check the next expression *) + check_texpression ctx e_next + | Switch (scrut, switch_body) -> ( + check_texpression ctx scrut; + match switch_body with + | If (e_then, e_else) -> + assert (scrut.ty = Bool); + assert (e_then.ty = e.ty); + assert (e_else.ty = e.ty); + check_texpression ctx e_then; + check_texpression ctx e_else + | Match branches -> + let check_branch (br : match_branch) : unit = + assert (br.pat.ty = scrut.ty); + let ctx = check_typed_pattern ctx br.pat in + check_texpression ctx br.branch + in + List.iter check_branch branches) + | Meta (_, e_next) -> + assert (e_next.ty = e.ty); + check_texpression ctx e_next diff --git a/compiler/PureUtils.ml b/compiler/PureUtils.ml new file mode 100644 index 00000000..39f3d76a --- /dev/null +++ b/compiler/PureUtils.ml @@ -0,0 +1,450 @@ +open Pure + +(** Default logger *) +let log = Logging.pure_utils_log + +(** We use this type as a key for lookups *) +type regular_fun_id = A.fun_id * T.RegionGroupId.id option +[@@deriving show, ord] + +module RegularFunIdOrderedType = struct + type t = regular_fun_id + + let compare = compare_regular_fun_id + let to_string = show_regular_fun_id + let pp_t = pp_regular_fun_id + let show_t = show_regular_fun_id +end + +module RegularFunIdMap = Collections.MakeMap (RegularFunIdOrderedType) + +module FunIdOrderedType = struct + type t = fun_id + + let compare = compare_fun_id + let to_string = show_fun_id + let pp_t = pp_fun_id + let show_t = show_fun_id +end + +module FunIdMap = Collections.MakeMap (FunIdOrderedType) +module FunIdSet = Collections.MakeSet (FunIdOrderedType) + +let dest_arrow_ty (ty : ty) : ty * ty = + match ty with + | Arrow (arg_ty, ret_ty) -> (arg_ty, ret_ty) + | _ -> raise (Failure "Unreachable") + +let compute_constant_value_ty (cv : constant_value) : ty = + match cv with + | V.Scalar sv -> Integer sv.V.int_ty + | Bool _ -> Bool + | Char _ -> Char + | String _ -> Str + +let mk_typed_pattern_from_constant_value (cv : constant_value) : typed_pattern = + let ty = compute_constant_value_ty cv in + { value = PatConcrete cv; ty } + +let mk_let (monadic : bool) (lv : typed_pattern) (re : texpression) + (next_e : texpression) : texpression = + let e = Let (monadic, lv, re, next_e) in + let ty = next_e.ty in + { e; ty } + +(** Type substitution *) +let ty_substitute (tsubst : TypeVarId.id -> ty) (ty : ty) : ty = + let obj = + object + inherit [_] map_ty + method! visit_TypeVar _ var_id = tsubst var_id + end + in + obj#visit_ty () ty + +let make_type_subst (vars : type_var list) (tys : ty list) : TypeVarId.id -> ty + = + let ls = List.combine vars tys in + let mp = + List.fold_left + (fun mp (k, v) -> TypeVarId.Map.add (k : type_var).index v mp) + TypeVarId.Map.empty ls + in + fun id -> TypeVarId.Map.find id mp + +(** Retrieve the list of fields for the given variant of a {!Pure.type_decl}. + + Raises [Invalid_argument] if the arguments are incorrect. + *) +let type_decl_get_fields (def : type_decl) + (opt_variant_id : VariantId.id option) : field list = + match (def.kind, opt_variant_id) with + | Enum variants, Some variant_id -> (VariantId.nth variants variant_id).fields + | Struct fields, None -> fields + | _ -> + let opt_variant_id = + match opt_variant_id with None -> "None" | Some _ -> "Some" + in + raise + (Invalid_argument + ("The variant id should be [Some] if and only if the definition is \ + an enumeration:\n\ + - def: " ^ show_type_decl def ^ "\n- opt_variant_id: " + ^ opt_variant_id)) + +(** Instantiate the type variables for the chosen variant in an ADT definition, + and return the list of the types of its fields *) +let type_decl_get_instantiated_fields_types (def : type_decl) + (opt_variant_id : VariantId.id option) (types : ty list) : ty list = + let ty_subst = make_type_subst def.type_params types in + let fields = type_decl_get_fields def opt_variant_id in + List.map (fun f -> ty_substitute ty_subst f.field_ty) fields + +let fun_sig_substitute (tsubst : TypeVarId.id -> ty) (sg : fun_sig) : + inst_fun_sig = + let subst = ty_substitute tsubst in + let inputs = List.map subst sg.inputs in + let output = subst sg.output in + let doutputs = List.map subst sg.doutputs in + let info = sg.info in + { inputs; output; doutputs; info } + +(** Return true if a list of functions are *not* mutually recursive, false otherwise. + This function is meant to be applied on a set of (forward, backwards) functions + generated for one recursive function. + The way we do the test is very simple: + - we explore the functions one by one, in the order + - if all functions only call functions we already explored, they are not + mutually recursive + *) +let functions_not_mutually_recursive (funs : fun_decl list) : bool = + (* Compute the set of function identifiers in the group *) + let ids = + FunIdSet.of_list + (List.map + (fun (f : fun_decl) -> Regular (A.Regular f.def_id, f.back_id)) + funs) + in + let ids = ref ids in + (* Explore every body *) + let body_only_calls_itself (fdef : fun_decl) : bool = + (* Remove the current id from the id set *) + ids := FunIdSet.remove (Regular (A.Regular fdef.def_id, fdef.back_id)) !ids; + + (* Check if we call functions from the updated id set *) + let obj = + object + inherit [_] iter_expression as super + + method! visit_qualif env qualif = + match qualif.id with + | Func fun_id -> + if FunIdSet.mem fun_id !ids then raise Utils.Found + else super#visit_qualif env qualif + | _ -> super#visit_qualif env qualif + end + in + + try + match fdef.body with + | None -> true + | Some body -> + obj#visit_texpression () body.body; + true + with Utils.Found -> false + in + List.for_all body_only_calls_itself funs + +(** We use this to check whether we need to add parentheses around expressions. + We only look for outer monadic let-bindings. + This is used when printing the branches of [if ... then ... else ...]. + *) +let rec let_group_requires_parentheses (e : texpression) : bool = + match e.e with + | Var _ | Const _ | App _ | Abs _ | Qualif _ -> false + | Let (monadic, _, _, next_e) -> + if monadic then true else let_group_requires_parentheses next_e + | Switch (_, _) -> false + | Meta (_, next_e) -> let_group_requires_parentheses next_e + +let is_var (e : texpression) : bool = + match e.e with Var _ -> true | _ -> false + +let as_var (e : texpression) : VarId.id = + match e.e with Var v -> v | _ -> raise (Failure "Unreachable") + +let is_global (e : texpression) : bool = + match e.e with Qualif { id = Global _; _ } -> true | _ -> false + +let is_const (e : texpression) : bool = + match e.e with Const _ -> true | _ -> false + +(** Remove the external occurrences of {!Meta} *) +let rec unmeta (e : texpression) : texpression = + match e.e with Meta (_, e) -> unmeta e | _ -> e + +(** Remove *all* the meta information *) +let remove_meta (e : texpression) : texpression = + let obj = + object + inherit [_] map_expression as super + method! visit_Meta env _ e = super#visit_expression env e.e + end + in + obj#visit_texpression () e + +let mk_arrow (ty0 : ty) (ty1 : ty) : ty = Arrow (ty0, ty1) + +(** Construct a type as a list of arrows: ty1 -> ... tyn *) +let mk_arrows (inputs : ty list) (output : ty) = + let rec aux (tys : ty list) : ty = + match tys with [] -> output | ty :: tys' -> Arrow (ty, aux tys') + in + aux inputs + +(** Destruct an [App] expression into an expression and a list of arguments. + + We simply destruct the expression as long as it is of the form [App (f, x)]. + *) +let destruct_apps (e : texpression) : texpression * texpression list = + let rec aux (args : texpression list) (e : texpression) : + texpression * texpression list = + match e.e with App (f, x) -> aux (x :: args) f | _ -> (e, args) + in + aux [] e + +(** Make an [App (app, arg)] expression *) +let mk_app (app : texpression) (arg : texpression) : texpression = + match app.ty with + | Arrow (ty0, ty1) -> + (* Sanity check *) + assert (ty0 = arg.ty); + let e = App (app, arg) in + let ty = ty1 in + { e; ty } + | _ -> raise (Failure "Expected an arrow type") + +(** The reverse of {!destruct_apps} *) +let mk_apps (app : texpression) (args : texpression list) : texpression = + List.fold_left (fun app arg -> mk_app app arg) app args + +(** Destruct an expression into a qualif identifier and a list of arguments, + * if possible *) +let opt_destruct_qualif_app (e : texpression) : + (qualif * texpression list) option = + let app, args = destruct_apps e in + match app.e with Qualif qualif -> Some (qualif, args) | _ -> None + +(** Destruct an expression into a qualif identifier and a list of arguments *) +let destruct_qualif_app (e : texpression) : qualif * texpression list = + Option.get (opt_destruct_qualif_app e) + +(** Destruct an expression into a function call, if possible *) +let opt_destruct_function_call (e : texpression) : + (fun_id * ty list * texpression list) option = + match opt_destruct_qualif_app e with + | None -> None + | Some (qualif, args) -> ( + match qualif.id with + | Func fun_id -> Some (fun_id, qualif.type_args, args) + | _ -> None) + +let opt_destruct_result (ty : ty) : ty option = + match ty with + | Adt (Assumed Result, tys) -> Some (Collections.List.to_cons_nil tys) + | _ -> None + +let destruct_result (ty : ty) : ty = Option.get (opt_destruct_result ty) + +let opt_destruct_tuple (ty : ty) : ty list option = + match ty with Adt (Tuple, tys) -> Some tys | _ -> None + +let mk_abs (x : typed_pattern) (e : texpression) : texpression = + let ty = Arrow (x.ty, e.ty) in + let e = Abs (x, e) in + { e; ty } + +let rec destruct_abs_list (e : texpression) : typed_pattern list * texpression = + match e.e with + | Abs (x, e') -> + let xl, e'' = destruct_abs_list e' in + (x :: xl, e'') + | _ -> ([], e) + +let destruct_arrow (ty : ty) : ty * ty = + match ty with + | Arrow (ty0, ty1) -> (ty0, ty1) + | _ -> raise (Failure "Not an arrow type") + +let rec destruct_arrows (ty : ty) : ty list * ty = + match ty with + | Arrow (ty0, ty1) -> + let tys, out_ty = destruct_arrows ty1 in + (ty0 :: tys, out_ty) + | _ -> ([], ty) + +let get_switch_body_ty (sb : switch_body) : ty = + match sb with + | If (e_then, _) -> e_then.ty + | Match branches -> + (* There should be at least one branch *) + (List.hd branches).branch.ty + +let map_switch_body_branches (f : texpression -> texpression) (sb : switch_body) + : switch_body = + match sb with + | If (e_then, e_else) -> If (f e_then, f e_else) + | Match branches -> + Match + (List.map + (fun (b : match_branch) -> { b with branch = f b.branch }) + branches) + +let iter_switch_body_branches (f : texpression -> unit) (sb : switch_body) : + unit = + match sb with + | If (e_then, e_else) -> + f e_then; + f e_else + | Match branches -> List.iter (fun (b : match_branch) -> f b.branch) branches + +let mk_switch (scrut : texpression) (sb : switch_body) : texpression = + (* Sanity check: the scrutinee has the proper type *) + (match sb with + | If (_, _) -> assert (scrut.ty = Bool) + | Match branches -> + List.iter + (fun (b : match_branch) -> assert (b.pat.ty = scrut.ty)) + branches); + (* Sanity check: all the branches have the same type *) + let ty = get_switch_body_ty sb in + iter_switch_body_branches (fun e -> assert (e.ty = ty)) sb; + (* Put together *) + let e = Switch (scrut, sb) in + { e; ty } + +(** Make a "simplified" tuple type from a list of types: + - if there is exactly one type, just return it + - if there is > one type: wrap them in a tuple + *) +let mk_simpl_tuple_ty (tys : ty list) : ty = + match tys with [ ty ] -> ty | _ -> Adt (Tuple, tys) + +let mk_unit_ty : ty = Adt (Tuple, []) + +let mk_unit_rvalue : texpression = + let id = AdtCons { adt_id = Tuple; variant_id = None } in + let qualif = { id; type_args = [] } in + let e = Qualif qualif in + let ty = mk_unit_ty in + { e; ty } + +let mk_texpression_from_var (v : var) : texpression = + let e = Var v.id in + let ty = v.ty in + { e; ty } + +let mk_typed_pattern_from_var (v : var) (mp : mplace option) : typed_pattern = + let value = PatVar (v, mp) in + let ty = v.ty in + { value; ty } + +let mk_meta (m : meta) (e : texpression) : texpression = + let ty = e.ty in + let e = Meta (m, e) in + { e; ty } + +let mk_mplace_texpression (mp : mplace) (e : texpression) : texpression = + mk_meta (MPlace mp) e + +let mk_opt_mplace_texpression (mp : mplace option) (e : texpression) : + texpression = + match mp with None -> e | Some mp -> mk_mplace_texpression mp e + +(** Make a "simplified" tuple value from a list of values: + - if there is exactly one value, just return it + - if there is > one value: wrap them in a tuple + *) +let mk_simpl_tuple_pattern (vl : typed_pattern list) : typed_pattern = + match vl with + | [ v ] -> v + | _ -> + let tys = List.map (fun (v : typed_pattern) -> v.ty) vl in + let ty = Adt (Tuple, tys) in + let value = PatAdt { variant_id = None; field_values = vl } in + { value; ty } + +(** Similar to {!mk_simpl_tuple_pattern} *) +let mk_simpl_tuple_texpression (vl : texpression list) : texpression = + match vl with + | [ v ] -> v + | _ -> + (* Compute the types of the fields, and the type of the tuple constructor *) + let tys = List.map (fun (v : texpression) -> v.ty) vl in + let ty = Adt (Tuple, tys) in + let ty = mk_arrows tys ty in + (* Construct the tuple constructor qualifier *) + let id = AdtCons { adt_id = Tuple; variant_id = None } in + let qualif = { id; type_args = tys } in + (* Put everything together *) + let cons = { e = Qualif qualif; ty } in + mk_apps cons vl + +let mk_adt_pattern (adt_ty : ty) (variant_id : VariantId.id) + (vl : typed_pattern list) : typed_pattern = + let value = PatAdt { variant_id = Some variant_id; field_values = vl } in + { value; ty = adt_ty } + +let ty_as_integer (t : ty) : T.integer_type = + match t with Integer int_ty -> int_ty | _ -> raise (Failure "Unreachable") + +(* TODO: move *) +let type_decl_is_enum (def : T.type_decl) : bool = + match def.kind with T.Struct _ -> false | Enum _ -> true | Opaque -> false + +let mk_state_ty : ty = Adt (Assumed State, []) +let mk_result_ty (ty : ty) : ty = Adt (Assumed Result, [ ty ]) + +let unwrap_result_ty (ty : ty) : ty = + match ty with + | Adt (Assumed Result, [ ty ]) -> ty + | _ -> failwith "not a result type" + +let mk_result_fail_texpression (ty : ty) : texpression = + let type_args = [ ty ] in + let ty = Adt (Assumed Result, type_args) in + let id = + AdtCons { adt_id = Assumed Result; variant_id = Some result_fail_id } + in + let qualif = { id; type_args } in + let cons_e = Qualif qualif in + let cons_ty = ty in + let cons = { e = cons_e; ty = cons_ty } in + cons + +let mk_result_return_texpression (v : texpression) : texpression = + let type_args = [ v.ty ] in + let ty = Adt (Assumed Result, type_args) in + let id = + AdtCons { adt_id = Assumed Result; variant_id = Some result_return_id } + in + let qualif = { id; type_args } in + let cons_e = Qualif qualif in + let cons_ty = mk_arrow v.ty ty in + let cons = { e = cons_e; ty = cons_ty } in + mk_app cons v + +let mk_result_fail_pattern (ty : ty) : typed_pattern = + let ty = Adt (Assumed Result, [ ty ]) in + let value = PatAdt { variant_id = Some result_fail_id; field_values = [] } in + { value; ty } + +let mk_result_return_pattern (v : typed_pattern) : typed_pattern = + let ty = Adt (Assumed Result, [ v.ty ]) in + let value = + PatAdt { variant_id = Some result_return_id; field_values = [ v ] } + in + { value; ty } + +let opt_unmeta_mplace (e : texpression) : mplace option * texpression = + match e.e with Meta (MPlace mp, e) -> (Some mp, e) | _ -> (None, e) diff --git a/compiler/Scalars.ml b/compiler/Scalars.ml new file mode 100644 index 00000000..03ca506c --- /dev/null +++ b/compiler/Scalars.ml @@ -0,0 +1,59 @@ +open Types +open Values + +(** The minimum/maximum values an integer type can have depending on its type *) + +let i8_min = Z.of_string "-128" +let i8_max = Z.of_string "127" +let i16_min = Z.of_string "-32768" +let i16_max = Z.of_string "32767" +let i32_min = Z.of_string "-2147483648" +let i32_max = Z.of_string "2147483647" +let i64_min = Z.of_string "-9223372036854775808" +let i64_max = Z.of_string "9223372036854775807" +let i128_min = Z.of_string "-170141183460469231731687303715884105728" +let i128_max = Z.of_string "170141183460469231731687303715884105727" +let u8_min = Z.of_string "0" +let u8_max = Z.of_string "255" +let u16_min = Z.of_string "0" +let u16_max = Z.of_string "65535" +let u32_min = Z.of_string "0" +let u32_max = Z.of_string "4294967295" +let u64_min = Z.of_string "0" +let u64_max = Z.of_string "18446744073709551615" +let u128_min = Z.of_string "0" +let u128_max = Z.of_string "340282366920938463463374607431768211455" + +(** Being a bit conservative about isize/usize: depending on the system, + the values are encoded as 32-bit values or 64-bit values - we may + want to take that into account in the future *) + +let isize_min = i32_min +let isize_max = i32_max +let usize_min = u32_min +let usize_max = u32_max + +(** Check that an integer value is in range *) +let check_int_in_range (int_ty : integer_type) (i : big_int) : bool = + match int_ty with + | Isize -> Z.leq isize_min i && Z.leq i isize_max + | I8 -> Z.leq i8_min i && Z.leq i i8_max + | I16 -> Z.leq i16_min i && Z.leq i i16_max + | I32 -> Z.leq i32_min i && Z.leq i i32_max + | I64 -> Z.leq i64_min i && Z.leq i i64_max + | I128 -> Z.leq i128_min i && Z.leq i i128_max + | Usize -> Z.leq usize_min i && Z.leq i usize_max + | U8 -> Z.leq u8_min i && Z.leq i u8_max + | U16 -> Z.leq u16_min i && Z.leq i u16_max + | U32 -> Z.leq u32_min i && Z.leq i u32_max + | U64 -> Z.leq u64_min i && Z.leq i u64_max + | U128 -> Z.leq u128_min i && Z.leq i u128_max + +(** Check that a scalar value is correct (the integer value it contains is in range) *) +let check_scalar_value_in_range (v : scalar_value) : bool = + check_int_in_range v.int_ty v.value + +(** Make a scalar value, while checking the value is in range *) +let mk_scalar (int_ty : integer_type) (i : big_int) : + (scalar_value, unit) result = + if check_int_in_range int_ty i then Ok { value = i; int_ty } else Error () diff --git a/compiler/StringUtils.ml b/compiler/StringUtils.ml new file mode 100644 index 00000000..0fd46136 --- /dev/null +++ b/compiler/StringUtils.ml @@ -0,0 +1,106 @@ +(** Utilities to work on strings, character per character. + + They operate on ASCII strings, and are used by the project to convert + Rust names: Rust names are not fancy, so it shouldn't be a problem. + + Rk.: the poor support of OCaml for char manipulation is really annoying... + *) + +let code_0 = 48 +let code_9 = 57 +let code_A = 65 +let code_Z = 90 +let code_a = 97 +let code_z = 122 + +let is_lowercase_ascii (c : char) : bool = + let c = Char.code c in + code_a <= c && c <= code_z + +let is_uppercase_ascii (c : char) : bool = + let c = Char.code c in + code_A <= c && c <= code_Z + +let is_letter_ascii (c : char) : bool = + is_lowercase_ascii c || is_uppercase_ascii c + +let is_digit_ascii (c : char) : bool = + let c = Char.code c in + code_0 <= c && c <= code_9 + +let lowercase_ascii = Char.lowercase_ascii +let uppercase_ascii = Char.uppercase_ascii + +(** Using buffers as per: + {{: https://stackoverflow.com/questions/29957418/how-to-convert-char-list-to-string-in-ocaml} stackoverflow} + *) +let string_of_chars (chars : char list) : string = + let buf = Buffer.create (List.length chars) in + List.iter (Buffer.add_char buf) chars; + Buffer.contents buf + +let string_to_chars (s : string) : char list = + let length = String.length s in + let rec apply i = + if i = length then [] else String.get s i :: apply (i + 1) + in + apply 0 + +(** This operates on ASCII *) +let to_camel_case (s : string) : string = + (* Note that we rebuild the string in reverse order *) + let apply ((prev_is_under, acc) : bool * char list) (c : char) : + bool * char list = + if c = '_' then (true, acc) + else + let c = if prev_is_under then uppercase_ascii c else c in + (false, c :: acc) + in + let _, chars = List.fold_left apply (true, []) (string_to_chars s) in + string_of_chars (List.rev chars) + +(** This operates on ASCII *) +let to_snake_case (s : string) : string = + (* Note that we rebuild the string in reverse order *) + let apply ((prev_is_low, prev_is_digit, acc) : bool * bool * char list) + (c : char) : bool * bool * char list = + let acc = + if c = '_' then acc + else if prev_is_digit then if is_letter_ascii c then '_' :: acc else acc + else if prev_is_low then + if (is_lowercase_ascii c || is_digit_ascii c) && c <> '_' then acc + else '_' :: acc + else acc + in + let prev_is_low = is_lowercase_ascii c in + let prev_is_digit = is_digit_ascii c in + let c = lowercase_ascii c in + (prev_is_low, prev_is_digit, c :: acc) + in + let _, _, chars = + List.fold_left apply (false, false, []) (string_to_chars s) + in + string_of_chars (List.rev chars) + +(** Applies a map operation. + + This is very inefficient, but shouldn't be used much. + *) +let map (f : char -> string) (s : string) : string = + let sl = List.map f (string_to_chars s) in + let sl = List.map string_to_chars sl in + string_of_chars (List.concat sl) + +let capitalize_first_letter (s : string) : string = + let s = string_to_chars s in + let s = match s with [] -> s | c :: s' -> uppercase_ascii c :: s' in + string_of_chars s + +(** Unit tests *) +let _ = + assert (to_camel_case "hello_world" = "HelloWorld"); + assert (to_snake_case "HelloWorld36Hello" = "hello_world36_hello"); + assert (to_snake_case "HELLO" = "hello"); + assert (to_snake_case "T1" = "t1"); + assert (to_camel_case "list" = "List"); + assert (to_snake_case "is_cons" = "is_cons") diff --git a/compiler/Substitute.ml b/compiler/Substitute.ml new file mode 100644 index 00000000..5e5858de --- /dev/null +++ b/compiler/Substitute.ml @@ -0,0 +1,357 @@ +(** This file implements various substitution utilities to instantiate types, + function bodies, etc. + *) + +module T = Types +module TU = TypesUtils +module V = Values +module E = Expressions +module A = LlbcAst +module C = Contexts + +(** Substitute types variables and regions in a type. + + TODO: we can reimplement that with visitors. + *) +let rec ty_substitute (rsubst : 'r1 -> 'r2) + (tsubst : T.TypeVarId.id -> 'r2 T.ty) (ty : 'r1 T.ty) : 'r2 T.ty = + let open T in + let subst = ty_substitute rsubst tsubst in + (* helper *) + match ty with + | Adt (def_id, regions, tys) -> + Adt (def_id, List.map rsubst regions, List.map subst tys) + | Array aty -> Array (subst aty) + | Slice sty -> Slice (subst sty) + | Ref (r, ref_ty, ref_kind) -> Ref (rsubst r, subst ref_ty, ref_kind) + (* Below variants: we technically return the same value, but because + one has type ['r1 ty] and the other has type ['r2 ty], we need to + deconstruct then reconstruct *) + | Bool -> Bool + | Char -> Char + | Never -> Never + | Integer int_ty -> Integer int_ty + | Str -> Str + | TypeVar vid -> tsubst vid + +(** Convert an {!T.rty} to an {!T.ety} by erasing the region variables *) +let erase_regions (ty : T.rty) : T.ety = + ty_substitute (fun _ -> T.Erased) (fun vid -> T.TypeVar vid) ty + +(** Generate fresh regions for region variables. + + Return the list of new regions and appropriate substitutions from the + original region variables to the fresh regions. + + TODO: simplify? we only need the subst [T.RegionVarId.id -> T.RegionId.id] + *) +let fresh_regions_with_substs (region_vars : T.region_var list) : + T.RegionId.id list + * (T.RegionVarId.id -> T.RegionId.id) + * (T.RegionVarId.id T.region -> T.RegionId.id T.region) = + (* Generate fresh regions *) + let fresh_region_ids = List.map (fun _ -> C.fresh_region_id ()) region_vars in + (* Generate the map from region var ids to regions *) + let ls = List.combine region_vars fresh_region_ids in + let rid_map = + List.fold_left + (fun mp (k, v) -> T.RegionVarId.Map.add k.T.index v mp) + T.RegionVarId.Map.empty ls + in + (* Generate the substitution from region var id to region *) + let rid_subst id = T.RegionVarId.Map.find id rid_map in + (* Generate the substitution from region to region *) + let rsubst r = + match r with T.Static -> T.Static | T.Var id -> T.Var (rid_subst id) + in + (* Return *) + (fresh_region_ids, rid_subst, rsubst) + +(** Erase the regions in a type and substitute the type variables *) +let erase_regions_substitute_types (tsubst : T.TypeVarId.id -> T.ety) + (ty : 'r T.region T.ty) : T.ety = + let rsubst (_ : 'r T.region) : T.erased_region = T.Erased in + ty_substitute rsubst tsubst ty + +(** Create a region substitution from a list of region variable ids and a list of + regions (with which to substitute the region variable ids *) +let make_region_subst (var_ids : T.RegionVarId.id list) + (regions : 'r T.region list) : T.RegionVarId.id T.region -> 'r T.region = + let ls = List.combine var_ids regions in + let mp = + List.fold_left + (fun mp (k, v) -> T.RegionVarId.Map.add k v mp) + T.RegionVarId.Map.empty ls + in + fun r -> + match r with + | T.Static -> T.Static + | T.Var id -> T.RegionVarId.Map.find id mp + +(** Create a type substitution from a list of type variable ids and a list of + types (with which to substitute the type variable ids) *) +let make_type_subst (var_ids : T.TypeVarId.id list) (tys : 'r T.ty list) : + T.TypeVarId.id -> 'r T.ty = + let ls = List.combine var_ids tys in + let mp = + List.fold_left + (fun mp (k, v) -> T.TypeVarId.Map.add k v mp) + T.TypeVarId.Map.empty ls + in + fun id -> T.TypeVarId.Map.find id mp + +(** Instantiate the type variables in an ADT definition, and return, for + every variant, the list of the types of its fields *) +let type_decl_get_instantiated_variants_fields_rtypes (def : T.type_decl) + (regions : T.RegionId.id T.region list) (types : T.rty list) : + (T.VariantId.id option * T.rty list) list = + let r_subst = + make_region_subst + (List.map (fun x -> x.T.index) def.T.region_params) + regions + in + let ty_subst = + make_type_subst (List.map (fun x -> x.T.index) def.T.type_params) types + in + let (variants_fields : (T.VariantId.id option * T.field list) list) = + match def.T.kind with + | T.Enum variants -> + List.mapi + (fun i v -> (Some (T.VariantId.of_int i), v.T.fields)) + variants + | T.Struct fields -> [ (None, fields) ] + | T.Opaque -> + raise + (Failure + ("Can't retrieve the variants of an opaque type: " + ^ Names.name_to_string def.name)) + in + List.map + (fun (id, fields) -> + ( id, + List.map (fun f -> ty_substitute r_subst ty_subst f.T.field_ty) fields + )) + variants_fields + +(** Instantiate the type variables in an ADT definition, and return the list + of types of the fields for the chosen variant *) +let type_decl_get_instantiated_field_rtypes (def : T.type_decl) + (opt_variant_id : T.VariantId.id option) + (regions : T.RegionId.id T.region list) (types : T.rty list) : T.rty list = + let r_subst = + make_region_subst + (List.map (fun x -> x.T.index) def.T.region_params) + regions + in + let ty_subst = + make_type_subst (List.map (fun x -> x.T.index) def.T.type_params) types + in + let fields = TU.type_decl_get_fields def opt_variant_id in + List.map (fun f -> ty_substitute r_subst ty_subst f.T.field_ty) fields + +(** Return the types of the properly instantiated ADT's variant, provided a + context *) +let ctx_adt_get_instantiated_field_rtypes (ctx : C.eval_ctx) + (def_id : T.TypeDeclId.id) (opt_variant_id : T.VariantId.id option) + (regions : T.RegionId.id T.region list) (types : T.rty list) : T.rty list = + let def = C.ctx_lookup_type_decl ctx def_id in + type_decl_get_instantiated_field_rtypes def opt_variant_id regions types + +(** Return the types of the properly instantiated ADT value (note that + here, ADT is understood in its broad meaning: ADT, assumed value or tuple) *) +let ctx_adt_value_get_instantiated_field_rtypes (ctx : C.eval_ctx) + (adt : V.adt_value) (id : T.type_id) + (region_params : T.RegionId.id T.region list) (type_params : T.rty list) : + T.rty list = + match id with + | T.AdtId id -> + (* Retrieve the types of the fields *) + ctx_adt_get_instantiated_field_rtypes ctx id adt.V.variant_id + region_params type_params + | T.Tuple -> + assert (List.length region_params = 0); + type_params + | T.Assumed aty -> ( + match aty with + | T.Box | T.Vec -> + assert (List.length region_params = 0); + assert (List.length type_params = 1); + type_params + | T.Option -> + assert (List.length region_params = 0); + assert (List.length type_params = 1); + if adt.V.variant_id = Some T.option_some_id then type_params + else if adt.V.variant_id = Some T.option_none_id then [] + else failwith "Unrechable") + +(** Instantiate the type variables in an ADT definition, and return the list + of types of the fields for the chosen variant *) +let type_decl_get_instantiated_field_etypes (def : T.type_decl) + (opt_variant_id : T.VariantId.id option) (types : T.ety list) : T.ety list = + let ty_subst = + make_type_subst (List.map (fun x -> x.T.index) def.T.type_params) types + in + let fields = TU.type_decl_get_fields def opt_variant_id in + List.map + (fun f -> erase_regions_substitute_types ty_subst f.T.field_ty) + fields + +(** Return the types of the properly instantiated ADT's variant, provided a + context *) +let ctx_adt_get_instantiated_field_etypes (ctx : C.eval_ctx) + (def_id : T.TypeDeclId.id) (opt_variant_id : T.VariantId.id option) + (types : T.ety list) : T.ety list = + let def = C.ctx_lookup_type_decl ctx def_id in + type_decl_get_instantiated_field_etypes def opt_variant_id types + +(** Apply a type substitution to a place *) +let place_substitute (_tsubst : T.TypeVarId.id -> T.ety) (p : E.place) : E.place + = + (* There is nothing to do *) + p + +(** Apply a type substitution to an operand *) +let operand_substitute (tsubst : T.TypeVarId.id -> T.ety) (op : E.operand) : + E.operand = + let p_subst = place_substitute tsubst in + match op with + | E.Copy p -> E.Copy (p_subst p) + | E.Move p -> E.Move (p_subst p) + | E.Constant (ety, cv) -> + let rsubst x = x in + E.Constant (ty_substitute rsubst tsubst ety, cv) + +(** Apply a type substitution to an rvalue *) +let rvalue_substitute (tsubst : T.TypeVarId.id -> T.ety) (rv : E.rvalue) : + E.rvalue = + let op_subst = operand_substitute tsubst in + let p_subst = place_substitute tsubst in + match rv with + | E.Use op -> E.Use (op_subst op) + | E.Ref (p, bkind) -> E.Ref (p_subst p, bkind) + | E.UnaryOp (unop, op) -> E.UnaryOp (unop, op_subst op) + | E.BinaryOp (binop, op1, op2) -> + E.BinaryOp (binop, op_subst op1, op_subst op2) + | E.Discriminant p -> E.Discriminant (p_subst p) + | E.Aggregate (kind, ops) -> + let ops = List.map op_subst ops in + let kind = + match kind with + | E.AggregatedTuple -> E.AggregatedTuple + | E.AggregatedOption (variant_id, ty) -> + let rsubst r = r in + E.AggregatedOption (variant_id, ty_substitute rsubst tsubst ty) + | E.AggregatedAdt (def_id, variant_id, regions, tys) -> + let rsubst r = r in + E.AggregatedAdt + ( def_id, + variant_id, + regions, + List.map (ty_substitute rsubst tsubst) tys ) + in + E.Aggregate (kind, ops) + +(** Apply a type substitution to an assertion *) +let assertion_substitute (tsubst : T.TypeVarId.id -> T.ety) (a : A.assertion) : + A.assertion = + { A.cond = operand_substitute tsubst a.A.cond; A.expected = a.A.expected } + +(** Apply a type substitution to a call *) +let call_substitute (tsubst : T.TypeVarId.id -> T.ety) (call : A.call) : A.call + = + let rsubst x = x in + let type_args = List.map (ty_substitute rsubst tsubst) call.A.type_args in + let args = List.map (operand_substitute tsubst) call.A.args in + let dest = place_substitute tsubst call.A.dest in + (* Putting all the paramters on purpose: we want to get a compiler error if + something moves - we may add a field on which we need to apply a substitution *) + { + func = call.A.func; + region_args = call.A.region_args; + A.type_args; + args; + dest; + } + +(** Apply a type substitution to a statement *) +let rec statement_substitute (tsubst : T.TypeVarId.id -> T.ety) + (st : A.statement) : A.statement = + { st with A.content = raw_statement_substitute tsubst st.content } + +and raw_statement_substitute (tsubst : T.TypeVarId.id -> T.ety) + (st : A.raw_statement) : A.raw_statement = + match st with + | A.Assign (p, rvalue) -> + let p = place_substitute tsubst p in + let rvalue = rvalue_substitute tsubst rvalue in + A.Assign (p, rvalue) + | A.AssignGlobal g -> + (* Globals don't have type parameters *) + A.AssignGlobal g + | A.FakeRead p -> + let p = place_substitute tsubst p in + A.FakeRead p + | A.SetDiscriminant (p, vid) -> + let p = place_substitute tsubst p in + A.SetDiscriminant (p, vid) + | A.Drop p -> + let p = place_substitute tsubst p in + A.Drop p + | A.Assert assertion -> + let assertion = assertion_substitute tsubst assertion in + A.Assert assertion + | A.Call call -> + let call = call_substitute tsubst call in + A.Call call + | A.Panic | A.Return | A.Break _ | A.Continue _ | A.Nop -> st + | A.Sequence (st1, st2) -> + A.Sequence + (statement_substitute tsubst st1, statement_substitute tsubst st2) + | A.Switch (op, tgts) -> + A.Switch + (operand_substitute tsubst op, switch_targets_substitute tsubst tgts) + | A.Loop le -> A.Loop (statement_substitute tsubst le) + +(** Apply a type substitution to switch targets *) +and switch_targets_substitute (tsubst : T.TypeVarId.id -> T.ety) + (tgts : A.switch_targets) : A.switch_targets = + match tgts with + | A.If (st1, st2) -> + A.If (statement_substitute tsubst st1, statement_substitute tsubst st2) + | A.SwitchInt (int_ty, tgts, otherwise) -> + let tgts = + List.map (fun (sv, st) -> (sv, statement_substitute tsubst st)) tgts + in + let otherwise = statement_substitute tsubst otherwise in + A.SwitchInt (int_ty, tgts, otherwise) + +(** Apply a type substitution to a function body. Return the local variables + and the body. *) +let fun_body_substitute_in_body (tsubst : T.TypeVarId.id -> T.ety) + (body : A.fun_body) : A.var list * A.statement = + let rsubst r = r in + let locals = + List.map + (fun v -> { v with A.var_ty = ty_substitute rsubst tsubst v.A.var_ty }) + body.A.locals + in + let body = statement_substitute tsubst body.body in + (locals, body) + +(** Substitute a function signature *) +let substitute_signature (asubst : T.RegionGroupId.id -> V.AbstractionId.id) + (rsubst : T.RegionVarId.id -> T.RegionId.id) + (tsubst : T.TypeVarId.id -> T.rty) (sg : A.fun_sig) : A.inst_fun_sig = + let rsubst' (r : T.RegionVarId.id T.region) : T.RegionId.id T.region = + match r with T.Static -> T.Static | T.Var rid -> T.Var (rsubst rid) + in + let inputs = List.map (ty_substitute rsubst' tsubst) sg.A.inputs in + let output = ty_substitute rsubst' tsubst sg.A.output in + let subst_region_group (rg : T.region_var_group) : A.abs_region_group = + let id = asubst rg.id in + let regions = List.map rsubst rg.regions in + let parents = List.map asubst rg.parents in + { id; regions; parents } + in + let regions_hierarchy = List.map subst_region_group sg.A.regions_hierarchy in + { A.regions_hierarchy; inputs; output } diff --git a/compiler/SymbolicAst.ml b/compiler/SymbolicAst.ml new file mode 100644 index 00000000..604a7948 --- /dev/null +++ b/compiler/SymbolicAst.ml @@ -0,0 +1,98 @@ +(** The "symbolic" AST is the AST directly generated by the symbolic execution. + It is very rough and meant to be extremely straightforward to build during + the symbolic execution: we later apply transformations to generate the + pure AST that we export. *) + +module T = Types +module V = Values +module E = Expressions +module A = LlbcAst + +(** "Meta"-place: a place stored as meta-data. + + Whenever we need to introduce new symbolic variables, for instance because + of symbolic expansions, we try to store a "place", which gives information + about the origin of the values (this place information comes from assignment + information, etc.). + We later use this place information to generate meaningful name, to prettify + the generated code. + *) +type mplace = { + bv : Contexts.binder; + (** It is important that we store the binder, and not just the variable id, + because the most important information in a place is the name of the + variable! + *) + projection : E.projection; + (** We store the projection because we can, but it is actually not that useful *) +} + +type call_id = + | Fun of A.fun_id * V.FunCallId.id + (** A "regular" function (i.e., a function which is not a primitive operation) *) + | Unop of E.unop + | Binop of E.binop +[@@deriving show, ord] + +type call = { + call_id : call_id; + abstractions : V.AbstractionId.id list; + type_params : T.ety list; + args : V.typed_value list; + args_places : mplace option list; (** Meta information *) + dest : V.symbolic_value; + dest_place : mplace option; (** Meta information *) +} + +(** Meta information, not necessary for synthesis but useful to guide it to + generate a pretty output. + *) + +type meta = + | Assignment of mplace * V.typed_value * mplace option + (** We generated an assignment (destination, assigned value, src) *) + +(** **Rk.:** here, {!expression} is not at all equivalent to the expressions + used in LLBC: they are a first step towards lambda-calculus expressions. + *) +type expression = + | Return of V.typed_value option + (** There are two cases: + - the AST is for a forward function: the typed value should contain + the value which was in the return variable + - the AST is for a backward function: the typed value should be [None] + *) + | Panic + | FunCall of call * expression + | EndAbstraction of V.abs * expression + | EvalGlobal of A.GlobalDeclId.id * V.symbolic_value * expression + (** Evaluate a global to a fresh symbolic value *) + | Expansion of mplace option * V.symbolic_value * expansion + (** Expansion of a symbolic value. + + The place is "meta": it gives the path to the symbolic value (if available) + which got expanded (this path is available when the symbolic expansion + comes from a path evaluation, during an assignment for instance). + We use it to compute meaningful names for the variables we introduce, + to prettify the generated code. + *) + | Meta of meta * expression (** Meta information *) + +and expansion = + | ExpandNoBranch of V.symbolic_expansion * expression + (** A symbolic expansion which doesn't generate a branching. + Includes: + - concrete expansion + - borrow expansion + *Doesn't* include: + - expansion of ADTs with one variant + *) + | ExpandAdt of + (T.VariantId.id option * V.symbolic_value list * expression) list + (** ADT expansion *) + | ExpandBool of expression * expression + (** A boolean expansion (i.e, an [if ... then ... else ...]) *) + | ExpandInt of + T.integer_type * (V.scalar_value * expression) list * expression + (** An integer expansion (i.e, a switch over an integer). The last + expression is for the "otherwise" branch. *) diff --git a/compiler/SymbolicToPure.ml b/compiler/SymbolicToPure.ml new file mode 100644 index 00000000..de4fb4c1 --- /dev/null +++ b/compiler/SymbolicToPure.ml @@ -0,0 +1,1824 @@ +open Errors +open LlbcAstUtils +open Pure +open PureUtils +module Id = Identifiers +module S = SymbolicAst +module TA = TypesAnalysis +module L = Logging +module PP = PrintPure +module FA = FunsAnalysis + +(** The local logger *) +let log = L.symbolic_to_pure_log + +type config = { + filter_useless_back_calls : bool; + (** If [true], filter the useless calls to backward functions. + + The useless calls are calls to backward functions which have no outputs. + This case happens if the original Rust function only takes *shared* borrows + as inputs, and is thus pretty common. + + We are allowed to do this only because in this specific case, + the backward function fails *exactly* when the forward function fails + (they actually do exactly the same thing, the only difference being + that the forward function can potentially return a value), and upon + reaching the place where we should introduce a call to the backward + function, we know we have introduced a call to the forward function. + + Also note that in general, backward functions "do more things" than + forward functions, and have more opportunities to fail (even though + in the generated code, backward functions should fail exactly when + the forward functions fail). + + We might want to move this optimization to the micro-passes subsequent + to the translation from symbolic to pure, but it is really super easy + to do it when going from symbolic to pure. + Note that we later filter the useless *forward* calls in the micro-passes, + where it is more natural to do. + *) +} + +type type_context = { + llbc_type_decls : T.type_decl TypeDeclId.Map.t; + type_decls : type_decl TypeDeclId.Map.t; + (** We use this for type-checking (for sanity checks) when translating + values and functions. + This map is empty when we translate the types, then contains all + the translated types when we translate the functions. + *) + types_infos : TA.type_infos; (* TODO: rename to type_infos *) +} + +type fun_sig_named_outputs = { + sg : fun_sig; (** A function signature *) + output_names : string option list; + (** In case the signature is for a backward function, we may provides names + for the outputs. The reason is that the outputs of backward functions + come from (in case there are no nested borrows) borrows present in the + inputs of the original rust function. In this situation, we can use the + names of those inputs to name the outputs. Those names are very useful + to generate beautiful codes (we may need to introduce temporary variables + in the bodies of the backward functions to store the returned values, in + which case we use those names). + *) +} + +type fun_context = { + llbc_fun_decls : A.fun_decl A.FunDeclId.Map.t; + fun_sigs : fun_sig_named_outputs RegularFunIdMap.t; (** *) + fun_infos : FA.fun_info A.FunDeclId.Map.t; +} + +type global_context = { llbc_global_decls : A.global_decl A.GlobalDeclId.Map.t } + +(** Whenever we translate a function call or an ended abstraction, we + store the related information (this is useful when translating ended + children abstractions). + *) +type call_info = { + forward : S.call; + forward_inputs : texpression list; + (** Remember the list of inputs given to the forward function. + + Those inputs include the state input, if pertinent (in which case + it is the last input). + *) + backwards : (V.abs * texpression list) T.RegionGroupId.Map.t; + (** A map from region group id (i.e., backward function id) to + pairs (abstraction, additional arguments received by the backward function) + + TODO: remove? it is also in the bs_ctx ("abstractions" field) + *) +} + +(** Body synthesis context *) +type bs_ctx = { + type_context : type_context; + fun_context : fun_context; + global_context : global_context; + fun_decl : A.fun_decl; + bid : T.RegionGroupId.id option; (** TODO: rename *) + sg : fun_sig; + (** The function signature - useful in particular to translate [Panic] *) + sv_to_var : var V.SymbolicValueId.Map.t; + (** Whenever we encounter a new symbolic value (introduced because of + a symbolic expansion or upon ending an abstraction, for instance) + we introduce a new variable (with a let-binding). + *) + var_counter : VarId.generator; + state_var : VarId.id; + (** The current state variable, in case we use a state *) + forward_inputs : var list; + (** The input parameters for the forward function *) + backward_inputs : var list T.RegionGroupId.Map.t; + (** The input parameters for the backward functions *) + backward_outputs : var list T.RegionGroupId.Map.t; + (** The variables that the backward functions will output *) + calls : call_info V.FunCallId.Map.t; + (** The function calls we encountered so far *) + abstractions : (V.abs * texpression list) V.AbstractionId.Map.t; + (** The ended abstractions we encountered so far, with their additional input arguments *) +} + +let type_check_pattern (ctx : bs_ctx) (v : typed_pattern) : unit = + let env = VarId.Map.empty in + let ctx = + { + PureTypeCheck.type_decls = ctx.type_context.type_decls; + global_decls = ctx.global_context.llbc_global_decls; + env; + } + in + let _ = PureTypeCheck.check_typed_pattern ctx v in + () + +let type_check_texpression (ctx : bs_ctx) (e : texpression) : unit = + let env = VarId.Map.empty in + let ctx = + { + PureTypeCheck.type_decls = ctx.type_context.type_decls; + global_decls = ctx.global_context.llbc_global_decls; + env; + } + in + PureTypeCheck.check_texpression ctx e + +(* TODO: move *) +let bs_ctx_to_ast_formatter (ctx : bs_ctx) : Print.LlbcAst.ast_formatter = + Print.LlbcAst.fun_decl_to_ast_formatter ctx.type_context.llbc_type_decls + ctx.fun_context.llbc_fun_decls ctx.global_context.llbc_global_decls + ctx.fun_decl + +let bs_ctx_to_pp_ast_formatter (ctx : bs_ctx) : PrintPure.ast_formatter = + let type_params = ctx.fun_decl.signature.type_params in + let type_decls = ctx.type_context.llbc_type_decls in + let fun_decls = ctx.fun_context.llbc_fun_decls in + let global_decls = ctx.global_context.llbc_global_decls in + PrintPure.mk_ast_formatter type_decls fun_decls global_decls type_params + +let ty_to_string (ctx : bs_ctx) (ty : ty) : string = + let fmt = bs_ctx_to_pp_ast_formatter ctx in + let fmt = PrintPure.ast_to_type_formatter fmt in + PrintPure.ty_to_string fmt ty + +let type_decl_to_string (ctx : bs_ctx) (def : type_decl) : string = + let type_params = def.type_params in + let type_decls = ctx.type_context.llbc_type_decls in + let fmt = PrintPure.mk_type_formatter type_decls type_params in + PrintPure.type_decl_to_string fmt def + +let texpression_to_string (ctx : bs_ctx) (e : texpression) : string = + let fmt = bs_ctx_to_pp_ast_formatter ctx in + PrintPure.texpression_to_string fmt false "" " " e + +let fun_sig_to_string (ctx : bs_ctx) (sg : fun_sig) : string = + let type_params = sg.type_params in + let type_decls = ctx.type_context.llbc_type_decls in + let fun_decls = ctx.fun_context.llbc_fun_decls in + let global_decls = ctx.global_context.llbc_global_decls in + let fmt = + PrintPure.mk_ast_formatter type_decls fun_decls global_decls type_params + in + PrintPure.fun_sig_to_string fmt sg + +let fun_decl_to_string (ctx : bs_ctx) (def : Pure.fun_decl) : string = + let type_params = def.signature.type_params in + let type_decls = ctx.type_context.llbc_type_decls in + let fun_decls = ctx.fun_context.llbc_fun_decls in + let global_decls = ctx.global_context.llbc_global_decls in + let fmt = + PrintPure.mk_ast_formatter type_decls fun_decls global_decls type_params + in + PrintPure.fun_decl_to_string fmt def + +(* TODO: move *) +let abs_to_string (ctx : bs_ctx) (abs : V.abs) : string = + let fmt = bs_ctx_to_ast_formatter ctx in + let fmt = Print.LlbcAst.ast_to_value_formatter fmt in + let indent = "" in + let indent_incr = " " in + Print.Values.abs_to_string fmt indent indent_incr abs + +let get_instantiated_fun_sig (fun_id : A.fun_id) + (back_id : T.RegionGroupId.id option) (tys : ty list) (ctx : bs_ctx) : + inst_fun_sig = + (* Lookup the non-instantiated function signature *) + let sg = + (RegularFunIdMap.find (fun_id, back_id) ctx.fun_context.fun_sigs).sg + in + (* Create the substitution *) + let tsubst = make_type_subst sg.type_params tys in + (* Apply *) + fun_sig_substitute tsubst sg + +let bs_ctx_lookup_llbc_type_decl (id : TypeDeclId.id) (ctx : bs_ctx) : + T.type_decl = + TypeDeclId.Map.find id ctx.type_context.llbc_type_decls + +let bs_ctx_lookup_llbc_fun_decl (id : A.FunDeclId.id) (ctx : bs_ctx) : + A.fun_decl = + A.FunDeclId.Map.find id ctx.fun_context.llbc_fun_decls + +(* TODO: move *) +let bs_ctx_lookup_local_function_sig (def_id : A.FunDeclId.id) + (back_id : T.RegionGroupId.id option) (ctx : bs_ctx) : fun_sig = + let id = (A.Regular def_id, back_id) in + (RegularFunIdMap.find id ctx.fun_context.fun_sigs).sg + +let bs_ctx_register_forward_call (call_id : V.FunCallId.id) (forward : S.call) + (args : texpression list) (ctx : bs_ctx) : bs_ctx = + let calls = ctx.calls in + assert (not (V.FunCallId.Map.mem call_id calls)); + let info = + { forward; forward_inputs = args; backwards = T.RegionGroupId.Map.empty } + in + let calls = V.FunCallId.Map.add call_id info calls in + { ctx with calls } + +(** [back_args]: the *additional* list of inputs received by the backward function *) +let bs_ctx_register_backward_call (abs : V.abs) (back_args : texpression list) + (ctx : bs_ctx) : bs_ctx * fun_id = + (* Insert the abstraction in the call informations *) + let back_id = abs.back_id in + let info = V.FunCallId.Map.find abs.call_id ctx.calls in + assert (not (T.RegionGroupId.Map.mem back_id info.backwards)); + let backwards = + T.RegionGroupId.Map.add back_id (abs, back_args) info.backwards + in + let info = { info with backwards } in + let calls = V.FunCallId.Map.add abs.call_id info ctx.calls in + (* Insert the abstraction in the abstractions map *) + let abstractions = ctx.abstractions in + assert (not (V.AbstractionId.Map.mem abs.abs_id abstractions)); + let abstractions = + V.AbstractionId.Map.add abs.abs_id (abs, back_args) abstractions + in + (* Retrieve the fun_id *) + let fun_id = + match info.forward.call_id with + | S.Fun (fid, _) -> Regular (fid, Some abs.back_id) + | S.Unop _ | S.Binop _ -> raise (Failure "Unreachable") + in + (* Update the context and return *) + ({ ctx with calls; abstractions }, fun_id) + +let rec translate_sty (ty : T.sty) : ty = + let translate = translate_sty in + match ty with + | T.Adt (type_id, regions, tys) -> ( + (* Can't translate types with regions for now *) + assert (regions = []); + let tys = List.map translate tys in + match type_id with + | T.AdtId adt_id -> Adt (AdtId adt_id, tys) + | T.Tuple -> mk_simpl_tuple_ty tys + | T.Assumed aty -> ( + match aty with + | T.Vec -> Adt (Assumed Vec, tys) + | T.Option -> Adt (Assumed Option, tys) + | T.Box -> ( + (* Eliminate the boxes *) + match tys with + | [ ty ] -> ty + | _ -> + failwith + "Box/vec/option type with incorrect number of arguments"))) + | TypeVar vid -> TypeVar vid + | Bool -> Bool + | Char -> Char + | Never -> raise (Failure "Unreachable") + | Integer int_ty -> Integer int_ty + | Str -> Str + | Array ty -> Array (translate ty) + | Slice ty -> Slice (translate ty) + | Ref (_, rty, _) -> translate rty + +let translate_field (f : T.field) : field = + let field_name = f.field_name in + let field_ty = translate_sty f.field_ty in + { field_name; field_ty } + +let translate_fields (fl : T.field list) : field list = + List.map translate_field fl + +let translate_variant (v : T.variant) : variant = + let variant_name = v.variant_name in + let fields = translate_fields v.fields in + { variant_name; fields } + +let translate_variants (vl : T.variant list) : variant list = + List.map translate_variant vl + +(** Translate a type def kind to IM *) +let translate_type_decl_kind (kind : T.type_decl_kind) : type_decl_kind = + match kind with + | T.Struct fields -> Struct (translate_fields fields) + | T.Enum variants -> Enum (translate_variants variants) + | T.Opaque -> Opaque + +(** Translate a type definition from IM + + TODO: this is not symbolic to pure but IM to pure. Still, I don't see the + point of moving this definition for now. + *) +let translate_type_decl (def : T.type_decl) : type_decl = + (* Translate *) + let def_id = def.T.def_id in + let name = def.name in + (* Can't translate types with regions for now *) + assert (def.region_params = []); + let type_params = def.type_params in + let kind = translate_type_decl_kind def.T.kind in + { def_id; name; type_params; kind } + +(** Translate a type, seen as an input/output of a forward function + (preserve all borrows, etc.) +*) + +let rec translate_fwd_ty (types_infos : TA.type_infos) (ty : 'r T.ty) : ty = + let translate = translate_fwd_ty types_infos in + match ty with + | T.Adt (type_id, regions, tys) -> ( + (* Can't translate types with regions for now *) + assert (regions = []); + (* Translate the type parameters *) + let t_tys = List.map translate tys in + (* Eliminate boxes and simplify tuples *) + match type_id with + | AdtId _ | T.Assumed (T.Vec | T.Option) -> + (* No general parametricity for now *) + assert (not (List.exists (TypesUtils.ty_has_borrows types_infos) tys)); + let type_id = + match type_id with + | AdtId adt_id -> AdtId adt_id + | T.Assumed T.Vec -> Assumed Vec + | T.Assumed T.Option -> Assumed Option + | _ -> raise (Failure "Unreachable") + in + Adt (type_id, t_tys) + | Tuple -> + (* Note that if there is exactly one type, [mk_simpl_tuple_ty] is the + identity *) + mk_simpl_tuple_ty t_tys + | T.Assumed T.Box -> ( + (* We eliminate boxes *) + (* No general parametricity for now *) + assert (not (List.exists (TypesUtils.ty_has_borrows types_infos) tys)); + match t_tys with + | [ bty ] -> bty + | _ -> + failwith + "Unreachable: box/vec/option receives exactly one type \ + parameter")) + | TypeVar vid -> TypeVar vid + | Bool -> Bool + | Char -> Char + | Never -> raise (Failure "Unreachable") + | Integer int_ty -> Integer int_ty + | Str -> Str + | Array ty -> + assert (not (TypesUtils.ty_has_borrows types_infos ty)); + Array (translate ty) + | Slice ty -> + assert (not (TypesUtils.ty_has_borrows types_infos ty)); + Slice (translate ty) + | Ref (_, rty, _) -> translate rty + +(** Simply calls [translate_fwd_ty] *) +let ctx_translate_fwd_ty (ctx : bs_ctx) (ty : 'r T.ty) : ty = + let types_infos = ctx.type_context.types_infos in + translate_fwd_ty types_infos ty + +(** Translate a type, when some regions may have ended. + + We return an option, because the translated type may be empty. + + [inside_mut]: are we inside a mutable borrow? + *) +let rec translate_back_ty (types_infos : TA.type_infos) + (keep_region : 'r -> bool) (inside_mut : bool) (ty : 'r T.ty) : ty option = + let translate = translate_back_ty types_infos keep_region inside_mut in + (* A small helper for "leave" types *) + let wrap ty = if inside_mut then Some ty else None in + match ty with + | T.Adt (type_id, _, tys) -> ( + match type_id with + | T.AdtId _ | Assumed (T.Vec | T.Option) -> + (* Don't accept ADTs (which are not tuples) with borrows for now *) + assert (not (TypesUtils.ty_has_borrows types_infos ty)); + let type_id = + match type_id with + | T.AdtId id -> AdtId id + | T.Assumed T.Vec -> Assumed Vec + | T.Assumed T.Option -> Assumed Option + | T.Tuple | T.Assumed T.Box -> raise (Failure "Unreachable") + in + if inside_mut then + let tys_t = List.filter_map translate tys in + Some (Adt (type_id, tys_t)) + else None + | Assumed T.Box -> ( + (* Don't accept ADTs (which are not tuples) with borrows for now *) + assert (not (TypesUtils.ty_has_borrows types_infos ty)); + (* Eliminate the box *) + match tys with + | [ bty ] -> translate bty + | _ -> + failwith "Unreachable: boxes receive exactly one type parameter") + | T.Tuple -> ( + (* Tuples can contain borrows (which we eliminated) *) + let tys_t = List.filter_map translate tys in + match tys_t with + | [] -> None + | _ -> + (* Note that if there is exactly one type, [mk_simpl_tuple_ty] + * is the identity *) + Some (mk_simpl_tuple_ty tys_t))) + | TypeVar vid -> wrap (TypeVar vid) + | Bool -> wrap Bool + | Char -> wrap Char + | Never -> raise (Failure "Unreachable") + | Integer int_ty -> wrap (Integer int_ty) + | Str -> wrap Str + | Array ty -> ( + assert (not (TypesUtils.ty_has_borrows types_infos ty)); + match translate ty with None -> None | Some ty -> Some (Array ty)) + | Slice ty -> ( + assert (not (TypesUtils.ty_has_borrows types_infos ty)); + match translate ty with None -> None | Some ty -> Some (Slice ty)) + | Ref (r, rty, rkind) -> ( + match rkind with + | T.Shared -> + (* Ignore shared references, unless we are below a mutable borrow *) + if inside_mut then translate rty else None + | T.Mut -> + (* Dive in, remembering the fact that we are inside a mutable borrow *) + let inside_mut = true in + if keep_region r then + translate_back_ty types_infos keep_region inside_mut rty + else None) + +(** Simply calls [translate_back_ty] *) +let ctx_translate_back_ty (ctx : bs_ctx) (keep_region : 'r -> bool) + (inside_mut : bool) (ty : 'r T.ty) : ty option = + let types_infos = ctx.type_context.types_infos in + translate_back_ty types_infos keep_region inside_mut ty + +(** List the ancestors of an abstraction *) +let list_ancestor_abstractions_ids (ctx : bs_ctx) (abs : V.abs) : + V.AbstractionId.id list = + (* We could do something more "elegant" without references, but it is + * so much simpler to use references... *) + let abs_set = ref V.AbstractionId.Set.empty in + let rec gather (abs_id : V.AbstractionId.id) : unit = + if V.AbstractionId.Set.mem abs_id !abs_set then () + else ( + abs_set := V.AbstractionId.Set.add abs_id !abs_set; + let abs, _ = V.AbstractionId.Map.find abs_id ctx.abstractions in + List.iter gather abs.original_parents) + in + List.iter gather abs.original_parents; + let ids = !abs_set in + (* List the ancestors, in the proper order *) + let call_info = V.FunCallId.Map.find abs.call_id ctx.calls in + List.filter + (fun id -> V.AbstractionId.Set.mem id ids) + call_info.forward.abstractions + +let list_ancestor_abstractions (ctx : bs_ctx) (abs : V.abs) : + (V.abs * texpression list) list = + let abs_ids = list_ancestor_abstractions_ids ctx abs in + List.map (fun id -> V.AbstractionId.Map.find id ctx.abstractions) abs_ids + +(** Small utility. *) +let get_fun_effect_info (fun_infos : FA.fun_info A.FunDeclId.Map.t) + (fun_id : A.fun_id) (gid : T.RegionGroupId.id option) : fun_effect_info = + match fun_id with + | A.Regular fid -> + let info = A.FunDeclId.Map.find fid fun_infos in + let input_state = info.stateful in + let output_state = input_state && gid = None in + { can_fail = info.can_fail; input_state; output_state } + | A.Assumed aid -> + { + can_fail = Assumed.assumed_can_fail aid; + input_state = false; + output_state = false; + } + +(** Translate a function signature. + + Note that the function also takes a list of names for the inputs, and + computes, for every output for the backward functions, a corresponding + name (outputs for backward functions come from borrows in the inputs + of the forward function). + *) +let translate_fun_sig (fun_infos : FA.fun_info A.FunDeclId.Map.t) + (fun_id : A.fun_id) (types_infos : TA.type_infos) (sg : A.fun_sig) + (input_names : string option list) (bid : T.RegionGroupId.id option) : + fun_sig_named_outputs = + (* Retrieve the list of parent backward functions *) + let gid, parents = + match bid with + | None -> (None, T.RegionGroupId.Set.empty) + | Some bid -> + let parents = list_parent_region_groups sg bid in + (Some bid, parents) + in + (* List the inputs for: + * - the forward function + * - the parent backward functions, in proper order + * - the current backward function (if it is a backward function) + *) + let fwd_inputs = List.map (translate_fwd_ty types_infos) sg.inputs in + (* For the backward functions: for now we don't supported nested borrows, + * so just check that there aren't parent regions *) + assert (T.RegionGroupId.Set.is_empty parents); + (* Small helper to translate types for backward functions *) + let translate_back_ty_for_gid (gid : T.RegionGroupId.id) : T.sty -> ty option + = + let rg = T.RegionGroupId.nth sg.regions_hierarchy gid in + let regions = T.RegionVarId.Set.of_list rg.regions in + let keep_region r = + match r with + | T.Static -> raise Unimplemented + | T.Var r -> T.RegionVarId.Set.mem r regions + in + let inside_mut = false in + translate_back_ty types_infos keep_region inside_mut + in + (* Compute the additinal inputs for the current function, if it is a backward + * function *) + let back_inputs = + match gid with + | None -> [] + | Some gid -> + (* For now, we don't allow nested borrows, so the additional inputs to the + backward function can only come from borrows that were returned like + in (for the backward function we introduce for 'a): + {[ + fn f<'a>(...) -> &'a mut u32; + ]} + Upon ending the abstraction for 'a, we need to get back the borrow + the function returned. + *) + List.filter_map (translate_back_ty_for_gid gid) [ sg.output ] + in + (* Does the function take a state as input, does it return a state and can + * it fail? *) + let effect_info = get_fun_effect_info fun_infos fun_id bid in + (* *) + let state_ty = if effect_info.input_state then [ mk_state_ty ] else [] in + (* Concatenate the inputs, in the following order: + * - forward inputs + * - state input + * - backward inputs + *) + let inputs = List.concat [ fwd_inputs; state_ty; back_inputs ] in + (* Outputs *) + let output_names, doutputs = + match gid with + | None -> + (* This is a forward function: there is one (unnamed) output *) + ([ None ], [ translate_fwd_ty types_infos sg.output ]) + | Some gid -> + (* This is a backward function: there might be several outputs. + The outputs are the borrows inside the regions of the abstractions + and which are present in the input values. For instance, see: + {[ + fn f<'a>(x : &'a mut u32) -> ...; + ]} + Upon ending the abstraction for 'a, we give back the borrow which + was consumed through the [x] parameter. + *) + let outputs = + List.map + (fun (name, input_ty) -> + (name, translate_back_ty_for_gid gid input_ty)) + (List.combine input_names sg.inputs) + in + (* Filter *) + let outputs = + List.filter (fun (_, opt_ty) -> Option.is_some opt_ty) outputs + in + let outputs = + List.map (fun (name, opt_ty) -> (name, Option.get opt_ty)) outputs + in + List.split outputs + in + (* Create the return type *) + let output = + (* Group the outputs together *) + let output = mk_simpl_tuple_ty doutputs in + (* Add the output state *) + let output = + if effect_info.output_state then mk_simpl_tuple_ty [ mk_state_ty; output ] + else output + in + (* Wrap in a result type *) + if effect_info.can_fail then mk_result_ty output else output + in + (* Type parameters *) + let type_params = sg.type_params in + (* Return *) + let info = + { + num_fwd_inputs = List.length fwd_inputs; + num_back_inputs = + (if bid = None then None else Some (List.length back_inputs)); + effect_info; + } + in + let sg = { type_params; inputs; output; doutputs; info } in + { sg; output_names } + +let bs_ctx_fresh_state_var (ctx : bs_ctx) : bs_ctx * typed_pattern = + (* Generate the fresh variable *) + let id, var_counter = VarId.fresh ctx.var_counter in + let var = + { id; basename = Some ConstStrings.state_basename; ty = mk_state_ty } + in + let state_var = mk_typed_pattern_from_var var None in + (* Update the context *) + let ctx = { ctx with var_counter; state_var = id } in + (* Return *) + (ctx, state_var) + +let fresh_named_var_for_symbolic_value (basename : string option) + (sv : V.symbolic_value) (ctx : bs_ctx) : bs_ctx * var = + (* Generate the fresh variable *) + let id, var_counter = VarId.fresh ctx.var_counter in + let ty = ctx_translate_fwd_ty ctx sv.sv_ty in + let var = { id; basename; ty } in + (* Insert in the map *) + let sv_to_var = V.SymbolicValueId.Map.add sv.sv_id var ctx.sv_to_var in + (* Update the context *) + let ctx = { ctx with var_counter; sv_to_var } in + (* Return *) + (ctx, var) + +let fresh_var_for_symbolic_value (sv : V.symbolic_value) (ctx : bs_ctx) : + bs_ctx * var = + fresh_named_var_for_symbolic_value None sv ctx + +let fresh_vars_for_symbolic_values (svl : V.symbolic_value list) (ctx : bs_ctx) + : bs_ctx * var list = + List.fold_left_map (fun ctx sv -> fresh_var_for_symbolic_value sv ctx) ctx svl + +let fresh_named_vars_for_symbolic_values + (svl : (string option * V.symbolic_value) list) (ctx : bs_ctx) : + bs_ctx * var list = + List.fold_left_map + (fun ctx (name, sv) -> fresh_named_var_for_symbolic_value name sv ctx) + ctx svl + +(** This generates a fresh variable **which is not to be linked to any symbolic value** *) +let fresh_var (basename : string option) (ty : ty) (ctx : bs_ctx) : bs_ctx * var + = + (* Generate the fresh variable *) + let id, var_counter = VarId.fresh ctx.var_counter in + let var = { id; basename; ty } in + (* Update the context *) + let ctx = { ctx with var_counter } in + (* Return *) + (ctx, var) + +let fresh_vars (vars : (string option * ty) list) (ctx : bs_ctx) : + bs_ctx * var list = + List.fold_left_map (fun ctx (name, ty) -> fresh_var name ty ctx) ctx vars + +let lookup_var_for_symbolic_value (sv : V.symbolic_value) (ctx : bs_ctx) : var = + V.SymbolicValueId.Map.find sv.sv_id ctx.sv_to_var + +(** Peel boxes as long as the value is of the form [Box<T>] *) +let rec unbox_typed_value (v : V.typed_value) : V.typed_value = + match (v.value, v.ty) with + | V.Adt av, T.Adt (T.Assumed T.Box, _, _) -> ( + match av.field_values with + | [ bv ] -> unbox_typed_value bv + | _ -> raise (Failure "Unreachable")) + | _ -> v + +(** Translate a typed value. + + It is used, for instance, on values used as inputs for function calls. + + **IMPORTANT**: this function makes the assumption that the typed value + doesn't contain ⊥. This means in particular that symbolic values don't + contain ended regions. + + TODO: we might want to remember in the symbolic AST the set of ended + regions, at the points where we need it, for sanity checks (though the + sanity checks in the symbolic interpreter should be enough). + The points where we need this set so far: + - function call + - end abstraction + - return + *) +let rec typed_value_to_texpression (ctx : bs_ctx) (v : V.typed_value) : + texpression = + (* We need to ignore boxes *) + let v = unbox_typed_value v in + let translate = typed_value_to_texpression ctx in + (* Translate the type *) + let ty = ctx_translate_fwd_ty ctx v.ty in + (* Translate the value *) + let value = + match v.value with + | V.Concrete cv -> { e = Const cv; ty } + | Adt av -> ( + let variant_id = av.variant_id in + let field_values = List.map translate av.field_values in + (* Eliminate the tuple wrapper if it is a tuple with exactly one field *) + match v.ty with + | T.Adt (T.Tuple, _, _) -> + assert (variant_id = None); + mk_simpl_tuple_texpression field_values + | _ -> + (* Retrieve the type and the translated type arguments from the + * translated type (simpler this way) *) + let adt_id, type_args = + match ty with + | Adt (type_id, tys) -> (type_id, tys) + | _ -> raise (Failure "Unreachable") + in + (* Create the constructor *) + let qualif_id = AdtCons { adt_id; variant_id = av.variant_id } in + let qualif = { id = qualif_id; type_args } in + let cons_e = Qualif qualif in + let field_tys = + List.map (fun (v : texpression) -> v.ty) field_values + in + let cons_ty = mk_arrows field_tys ty in + let cons = { e = cons_e; ty = cons_ty } in + (* Apply the constructor *) + mk_apps cons field_values) + | Bottom -> raise (Failure "Unreachable") + | Loan lc -> ( + match lc with + | SharedLoan (_, v) -> translate v + | MutLoan _ -> raise (Failure "Unreachable")) + | Borrow bc -> ( + match bc with + | V.SharedBorrow (mv, _) -> + (* The meta-value stored in the shared borrow was added especially + * for this case (because we can't use the borrow id for lookups) *) + translate mv + | V.InactivatedMutBorrow (mv, _) -> + (* Same as for shared borrows. However, note that we use inactivated borrows + * only in meta-data: a value actually *used in the translation* can't come + * from an unpromoted inactivated borrow *) + translate mv + | V.MutBorrow (_, v) -> + (* Borrows are the identity in the extraction *) + translate v) + | Symbolic sv -> + let var = lookup_var_for_symbolic_value sv ctx in + mk_texpression_from_var var + in + (* Debugging *) + log#ldebug + (lazy + ("typed_value_to_texpression: result:" ^ "\n- input value:\n" + ^ V.show_typed_value v ^ "\n- translated expression:\n" + ^ show_texpression value)); + (* Sanity check *) + type_check_texpression ctx value; + (* Return *) + value + +(** Explore an abstraction value and convert it to a consumed value + by collecting all the meta-values from the ended *loans*. + + Consumed values are rvalues, because when an abstraction ends, we + introduce a call to a backward function in the synthesized program, + which takes as inputs those consumed values: + {[ + // Rust: + fn choose<'a>(b: bool, x : &'a mut u32, y : &'a mut u32) -> &'a mut u32; + + // Synthesis: + let ... = choose_back b x y nz in + ^^ + ]} + *) +let rec typed_avalue_to_consumed (ctx : bs_ctx) (av : V.typed_avalue) : + texpression option = + let translate = typed_avalue_to_consumed ctx in + let value = + match av.value with + | AConcrete _ -> raise (Failure "Unreachable") + | AAdt adt_v -> ( + (* Translate the field values *) + let field_values = List.filter_map translate adt_v.field_values in + (* For now, only tuples can contain borrows *) + let adt_id, _, _ = TypesUtils.ty_as_adt av.ty in + match adt_id with + | T.AdtId _ | T.Assumed (T.Box | T.Vec | T.Option) -> + assert (field_values = []); + None + | T.Tuple -> + (* Return *) + if field_values = [] then None + else + (* Note that if there is exactly one field value, + * [mk_simpl_tuple_rvalue] is the identity *) + let rv = mk_simpl_tuple_texpression field_values in + Some rv) + | ABottom -> raise (Failure "Unreachable") + | ALoan lc -> aloan_content_to_consumed ctx lc + | ABorrow bc -> aborrow_content_to_consumed ctx bc + | ASymbolic aproj -> aproj_to_consumed ctx aproj + | AIgnored -> None + in + (* Sanity check - Rk.: we do this at every recursive call, which is a bit + * expansive... *) + (match value with + | None -> () + | Some value -> type_check_texpression ctx value); + (* Return *) + value + +and aloan_content_to_consumed (ctx : bs_ctx) (lc : V.aloan_content) : + texpression option = + match lc with + | AMutLoan (_, _) | ASharedLoan (_, _, _) -> raise (Failure "Unreachable") + | AEndedMutLoan { child = _; given_back = _; given_back_meta } -> + (* Return the meta-value *) + Some (typed_value_to_texpression ctx given_back_meta) + | AEndedSharedLoan (_, _) -> + (* We don't dive into shared loans: there is nothing to give back + * inside (note that there could be a mutable borrow in the shared + * value, pointing to a mutable loan in the child avalue, but this + * borrow is in practice immutable) *) + None + | AIgnoredMutLoan (_, _) -> + (* There can be *inner* not ended mutable loans, but not outer ones *) + raise (Failure "Unreachable") + | AEndedIgnoredMutLoan _ -> + (* This happens with nested borrows: we need to dive in *) + raise Unimplemented + | AIgnoredSharedLoan _ -> + (* Ignore *) + None + +and aborrow_content_to_consumed (_ctx : bs_ctx) (bc : V.aborrow_content) : + texpression option = + match bc with + | V.AMutBorrow (_, _, _) | ASharedBorrow _ | AIgnoredMutBorrow (_, _) -> + raise (Failure "Unreachable") + | AEndedMutBorrow (_, _) -> + (* We collect consumed values: ignore *) + None + | AEndedIgnoredMutBorrow _ -> + (* This happens with nested borrows: we need to dive in *) + raise Unimplemented + | AEndedSharedBorrow | AProjSharedBorrow _ -> + (* Ignore *) + None + +and aproj_to_consumed (ctx : bs_ctx) (aproj : V.aproj) : texpression option = + match aproj with + | V.AEndedProjLoans (msv, []) -> + (* The symbolic value was left unchanged *) + let var = lookup_var_for_symbolic_value msv ctx in + Some (mk_texpression_from_var var) + | V.AEndedProjLoans (_, [ (mnv, child_aproj) ]) -> + assert (child_aproj = AIgnoredProjBorrows); + (* The symbolic value was updated *) + let var = lookup_var_for_symbolic_value mnv ctx in + Some (mk_texpression_from_var var) + | V.AEndedProjLoans (_, _) -> + (* The symbolic value was updated, and the given back values come from sevearl + * abstractions *) + raise Unimplemented + | AEndedProjBorrows _ -> (* We consider consumed values *) None + | AIgnoredProjBorrows | AProjLoans (_, _) | AProjBorrows (_, _) -> + raise (Failure "Unreachable") + +(** Convert the abstraction values in an abstraction to consumed values. + + See [typed_avalue_to_consumed]. + *) +let abs_to_consumed (ctx : bs_ctx) (abs : V.abs) : texpression list = + log#ldebug (lazy ("abs_to_consumed:\n" ^ abs_to_string ctx abs)); + List.filter_map (typed_avalue_to_consumed ctx) abs.avalues + +let translate_mprojection_elem (pe : E.projection_elem) : + mprojection_elem option = + match pe with + | Deref | DerefBox -> None + | Field (pkind, field_id) -> Some { pkind; field_id } + +let translate_mprojection (p : E.projection) : mprojection = + List.filter_map translate_mprojection_elem p + +(** Translate a "meta"-place *) +let translate_mplace (p : S.mplace) : mplace = + let var_id = p.bv.index in + let name = p.bv.name in + let projection = translate_mprojection p.projection in + { var_id; name; projection } + +let translate_opt_mplace (p : S.mplace option) : mplace option = + match p with None -> None | Some p -> Some (translate_mplace p) + +(** Explore an abstraction value and convert it to a given back value + by collecting all the meta-values from the ended *borrows*. + + Given back values are patterns, because when an abstraction ends, we + introduce a call to a backward function in the synthesized program, + which introduces new values: + {[ + let (nx, ny) = f_back ... in + ^^^^^^^^ + ]} + + [mp]: it is possible to provide some meta-place information, to guide + the heuristics which later find pretty names for the variables. + *) +let rec typed_avalue_to_given_back (mp : mplace option) (av : V.typed_avalue) + (ctx : bs_ctx) : bs_ctx * typed_pattern option = + let ctx, value = + match av.value with + | AConcrete _ -> raise (Failure "Unreachable") + | AAdt adt_v -> ( + (* Translate the field values *) + (* For now we forget the meta-place information so that it doesn't get used + * by several fields (which would then all have the same name...), but we + * might want to do something smarter *) + let mp = None in + let ctx, field_values = + List.fold_left_map + (fun ctx fv -> typed_avalue_to_given_back mp fv ctx) + ctx adt_v.field_values + in + let field_values = List.filter_map (fun x -> x) field_values in + (* For now, only tuples can contain borrows - note that if we gave + * something like a [&mut Vec] to a function, we give give back the + * vector value upon visiting the "abstraction borrow" node *) + let adt_id, _, _ = TypesUtils.ty_as_adt av.ty in + match adt_id with + | T.AdtId _ | T.Assumed (T.Box | T.Vec | T.Option) -> + assert (field_values = []); + (ctx, None) + | T.Tuple -> + (* Return *) + let variant_id = adt_v.variant_id in + assert (variant_id = None); + if field_values = [] then (ctx, None) + else + (* Note that if there is exactly one field value, [mk_simpl_tuple_pattern] + * is the identity *) + let lv = mk_simpl_tuple_pattern field_values in + (ctx, Some lv)) + | ABottom -> raise (Failure "Unreachable") + | ALoan lc -> aloan_content_to_given_back mp lc ctx + | ABorrow bc -> aborrow_content_to_given_back mp bc ctx + | ASymbolic aproj -> aproj_to_given_back mp aproj ctx + | AIgnored -> (ctx, None) + in + (* Sanity check - Rk.: we do this at every recursive call, which is a bit + * expansive... *) + (match value with None -> () | Some value -> type_check_pattern ctx value); + (* Return *) + (ctx, value) + +and aloan_content_to_given_back (_mp : mplace option) (lc : V.aloan_content) + (ctx : bs_ctx) : bs_ctx * typed_pattern option = + match lc with + | AMutLoan (_, _) | ASharedLoan (_, _, _) -> raise (Failure "Unreachable") + | AEndedMutLoan { child = _; given_back = _; given_back_meta = _ } + | AEndedSharedLoan (_, _) -> + (* We consider given back values, and thus ignore those *) + (ctx, None) + | AIgnoredMutLoan (_, _) -> + (* There can be *inner* not ended mutable loans, but not outer ones *) + raise (Failure "Unreachable") + | AEndedIgnoredMutLoan _ -> + (* This happens with nested borrows: we need to dive in *) + raise Unimplemented + | AIgnoredSharedLoan _ -> + (* Ignore *) + (ctx, None) + +and aborrow_content_to_given_back (mp : mplace option) (bc : V.aborrow_content) + (ctx : bs_ctx) : bs_ctx * typed_pattern option = + match bc with + | V.AMutBorrow (_, _, _) | ASharedBorrow _ | AIgnoredMutBorrow (_, _) -> + raise (Failure "Unreachable") + | AEndedMutBorrow (msv, _) -> + (* Return the meta-symbolic-value *) + let ctx, var = fresh_var_for_symbolic_value msv ctx in + (ctx, Some (mk_typed_pattern_from_var var mp)) + | AEndedIgnoredMutBorrow _ -> + (* This happens with nested borrows: we need to dive in *) + raise Unimplemented + | AEndedSharedBorrow | AProjSharedBorrow _ -> + (* Ignore *) + (ctx, None) + +and aproj_to_given_back (mp : mplace option) (aproj : V.aproj) (ctx : bs_ctx) : + bs_ctx * typed_pattern option = + match aproj with + | V.AEndedProjLoans (_, child_projs) -> + (* There may be children borrow projections in case of nested borrows, + * in which case we need to dive in - we disallow nested borrows for now *) + assert ( + List.for_all + (fun (_, aproj) -> aproj = V.AIgnoredProjBorrows) + child_projs); + (ctx, None) + | AEndedProjBorrows mv -> + (* Return the meta-value *) + let ctx, var = fresh_var_for_symbolic_value mv ctx in + (ctx, Some (mk_typed_pattern_from_var var mp)) + | AIgnoredProjBorrows | AProjLoans (_, _) | AProjBorrows (_, _) -> + raise (Failure "Unreachable") + +(** Convert the abstraction values in an abstraction to given back values. + + See [typed_avalue_to_given_back]. + *) +let abs_to_given_back (mpl : mplace option list) (abs : V.abs) (ctx : bs_ctx) : + bs_ctx * typed_pattern list = + let avalues = List.combine mpl abs.avalues in + let ctx, values = + List.fold_left_map + (fun ctx (mp, av) -> typed_avalue_to_given_back mp av ctx) + ctx avalues + in + let values = List.filter_map (fun x -> x) values in + (ctx, values) + +(** Simply calls [abs_to_given_back] *) +let abs_to_given_back_no_mp (abs : V.abs) (ctx : bs_ctx) : + bs_ctx * typed_pattern list = + let mpl = List.map (fun _ -> None) abs.avalues in + abs_to_given_back mpl abs ctx + +(** Return the ordered list of the (transitive) parents of a given abstraction. + + Is used for instance when collecting the input values given to all the + parent functions, in order to properly instantiate an + *) +let get_abs_ancestors (ctx : bs_ctx) (abs : V.abs) : + S.call * (V.abs * texpression list) list = + let call_info = V.FunCallId.Map.find abs.call_id ctx.calls in + let abs_ancestors = list_ancestor_abstractions ctx abs in + (call_info.forward, abs_ancestors) + +let rec translate_expression (config : config) (e : S.expression) (ctx : bs_ctx) + : texpression = + match e with + | S.Return opt_v -> translate_return opt_v ctx + | Panic -> translate_panic ctx + | FunCall (call, e) -> translate_function_call config call e ctx + | EndAbstraction (abs, e) -> translate_end_abstraction config abs e ctx + | EvalGlobal (gid, sv, e) -> translate_global_eval config gid sv e ctx + | Expansion (p, sv, exp) -> translate_expansion config p sv exp ctx + | Meta (meta, e) -> translate_meta config meta e ctx + +and translate_panic (ctx : bs_ctx) : texpression = + (* Here we use the function return type - note that it is ok because + * we don't match on panics which happen inside the function body - + * but it won't be true anymore once we translate individual blocks *) + (* If we use a state monad, we need to add a lambda for the state variable *) + (* Note that only forward functions return a state *) + let output_ty = mk_simpl_tuple_ty ctx.sg.doutputs in + if ctx.sg.info.effect_info.output_state then + (* Create the [Fail] value *) + let ret_ty = mk_simpl_tuple_ty [ mk_state_ty; output_ty ] in + let ret_v = mk_result_fail_texpression ret_ty in + ret_v + else mk_result_fail_texpression output_ty + +and translate_return (opt_v : V.typed_value option) (ctx : bs_ctx) : texpression + = + (* There are two cases: + - either we are translating a forward function, in which case the optional + value should be [Some] (it is the returned value) + - or we are translating a backward function, in which case it should be [None] + *) + match ctx.bid with + | None -> + (* Forward function *) + let v = Option.get opt_v in + let v = typed_value_to_texpression ctx v in + (* We may need to return a state + * - error-monad: Return x + * - state-error: Return (state, x) + * *) + if ctx.sg.info.effect_info.output_state then + let state_var = + { + id = ctx.state_var; + basename = Some ConstStrings.state_basename; + ty = mk_state_ty; + } + in + let state_rvalue = mk_texpression_from_var state_var in + mk_result_return_texpression + (mk_simpl_tuple_texpression [ state_rvalue; v ]) + else mk_result_return_texpression v + | Some bid -> + (* Backward function *) + (* Sanity check *) + assert (opt_v = None); + assert (not ctx.sg.info.effect_info.output_state); + (* We simply need to return the variables in which we stored the values + * we need to give back. + * See the explanations for the [SynthInput] case in [translate_end_abstraction] *) + let backward_outputs = + T.RegionGroupId.Map.find bid ctx.backward_outputs + in + let field_values = List.map mk_texpression_from_var backward_outputs in + (* Backward functions never return a state *) + (* TODO: we should use a [fail] function, it would be cleaner *) + let ret_value = mk_simpl_tuple_texpression field_values in + let ret_value = mk_result_return_texpression ret_value in + ret_value + +and translate_function_call (config : config) (call : S.call) (e : S.expression) + (ctx : bs_ctx) : texpression = + (* Translate the function call *) + let type_args = List.map (ctx_translate_fwd_ty ctx) call.type_params in + let args = + let args = List.map (typed_value_to_texpression ctx) call.args in + let args_mplaces = List.map translate_opt_mplace call.args_places in + List.map + (fun (arg, mp) -> mk_opt_mplace_texpression mp arg) + (List.combine args args_mplaces) + in + let dest_mplace = translate_opt_mplace call.dest_place in + let ctx, dest = fresh_var_for_symbolic_value call.dest ctx in + (* Retrieve the function id, and register the function call in the context + * if necessary. *) + let ctx, fun_id, effect_info, args, out_state = + match call.call_id with + | S.Fun (fid, call_id) -> + (* Regular function call *) + let func = Regular (fid, None) in + (* Retrieve the effect information about this function (can fail, + * takes a state as input, etc.) *) + let effect_info = + get_fun_effect_info ctx.fun_context.fun_infos fid None + in + (* Add the state input argument *) + let args = + if effect_info.input_state then + let state_var = { e = Var ctx.state_var; ty = mk_state_ty } in + List.append args [ state_var ] + else args + in + (* Generate a fresh state variable if the function call introduces + * a new variable *) + let ctx, out_state = + if effect_info.input_state then + let ctx, var = bs_ctx_fresh_state_var ctx in + (ctx, Some var) + else (ctx, None) + in + (* Register the function call *) + let ctx = bs_ctx_register_forward_call call_id call args ctx in + (ctx, func, effect_info, args, out_state) + | S.Unop E.Not -> + let effect_info = + { can_fail = false; input_state = false; output_state = false } + in + (ctx, Unop Not, effect_info, args, None) + | S.Unop E.Neg -> ( + match args with + | [ arg ] -> + let int_ty = ty_as_integer arg.ty in + (* Note that negation can lead to an overflow and thus fail (it + * is thus monadic) *) + let effect_info = + { can_fail = true; input_state = false; output_state = false } + in + (ctx, Unop (Neg int_ty), effect_info, args, None) + | _ -> raise (Failure "Unreachable")) + | S.Unop (E.Cast (src_ty, tgt_ty)) -> + (* Note that cast can fail *) + let effect_info = + { can_fail = true; input_state = false; output_state = false } + in + (ctx, Unop (Cast (src_ty, tgt_ty)), effect_info, args, None) + | S.Binop binop -> ( + match args with + | [ arg0; arg1 ] -> + let int_ty0 = ty_as_integer arg0.ty in + let int_ty1 = ty_as_integer arg1.ty in + assert (int_ty0 = int_ty1); + let effect_info = + { + can_fail = ExpressionsUtils.binop_can_fail binop; + input_state = false; + output_state = false; + } + in + (ctx, Binop (binop, int_ty0), effect_info, args, None) + | _ -> raise (Failure "Unreachable")) + in + let dest_v = + let dest = mk_typed_pattern_from_var dest dest_mplace in + match out_state with + | None -> dest + | Some out_state -> mk_simpl_tuple_pattern [ out_state; dest ] + in + let func = { id = Func fun_id; type_args } in + let input_tys = (List.map (fun (x : texpression) -> x.ty)) args in + let ret_ty = + if effect_info.can_fail then mk_result_ty dest_v.ty else dest_v.ty + in + let func_ty = mk_arrows input_tys ret_ty in + let func = { e = Qualif func; ty = func_ty } in + let call = mk_apps func args in + (* Translate the next expression *) + let next_e = translate_expression config e ctx in + (* Put together *) + mk_let effect_info.can_fail dest_v call next_e + +and translate_end_abstraction (config : config) (abs : V.abs) (e : S.expression) + (ctx : bs_ctx) : texpression = + log#ldebug + (lazy + ("translate_end_abstraction: abstraction kind: " + ^ V.show_abs_kind abs.kind)); + match abs.kind with + | V.SynthInput -> + (* When we end an input abstraction, this input abstraction gets back + * the borrows which it introduced in the context through the input + * values: by listing those values, we get the values which are given + * back by one of the backward functions we are synthesizing. *) + (* Note that we don't support nested borrows for now: if we find + * an ended synthesized input abstraction, it must be the one corresponding + * to the backward function wer are synthesizing, it can't be the one + * for a parent backward function. + *) + let bid = Option.get ctx.bid in + assert (abs.back_id = bid); + + (* The translation is done as follows: + * - for a given backward function, we choose a set of variables [v_i] + * - when we detect the ended input abstraction which corresponds + * to the backward function, and which consumed the values [consumed_i], + * we introduce: + * {[ + * let v_i = consumed_i in + * ... + * ]} + * Then, when we reach the [Return] node, we introduce: + * {[ + * (v_i) + * ]} + * *) + (* First, get the given back variables *) + let given_back_variables = + T.RegionGroupId.Map.find bid ctx.backward_outputs + in + (* Get the list of values consumed by the abstraction upon ending *) + let consumed_values = abs_to_consumed ctx abs in + (* Group the two lists *) + let variables_values = + List.combine given_back_variables consumed_values + in + (* Sanity check: the two lists match (same types) *) + List.iter + (fun (var, v) -> assert ((var : var).ty = (v : texpression).ty)) + variables_values; + (* Translate the next expression *) + let next_e = translate_expression config e ctx in + (* Generate the assignemnts *) + let monadic = false in + List.fold_right + (fun (var, value) (e : texpression) -> + mk_let monadic (mk_typed_pattern_from_var var None) value e) + variables_values next_e + | V.FunCall -> + let call_info = V.FunCallId.Map.find abs.call_id ctx.calls in + let call = call_info.forward in + let type_args = List.map (ctx_translate_fwd_ty ctx) call.type_params in + (* Retrieve the original call and the parent abstractions *) + let _forward, backwards = get_abs_ancestors ctx abs in + (* Retrieve the values consumed when we called the forward function and + * ended the parent backward functions: those give us part of the input + * values (rmk: for now, as we disallow nested lifetimes, there can't be + * parent backward functions). + * Note that the forward inputs include the input state (if there is one). *) + let fwd_inputs = call_info.forward_inputs in + let back_ancestors_inputs = + List.concat (List.map (fun (_abs, args) -> args) backwards) + in + (* Retrieve the values consumed upon ending the loans inside this + * abstraction: those give us the remaining input values *) + let back_inputs = abs_to_consumed ctx abs in + let inputs = + List.concat [ fwd_inputs; back_ancestors_inputs; back_inputs ] + in + (* Retrieve the values given back by this function: those are the output + * values. We rely on the fact that there are no nested borrows to use the + * meta-place information from the input values given to the forward function + * (we need to add [None] for the return avalue) *) + let output_mpl = + List.append (List.map translate_opt_mplace call.args_places) [ None ] + in + let ctx, outputs = abs_to_given_back output_mpl abs ctx in + (* Group the output values together (note that for now, backward functions + * never return an output state) *) + let output = mk_simpl_tuple_pattern outputs in + (* Sanity check: the inputs and outputs have the proper number and the proper type *) + let fun_id = + match call.call_id with + | S.Fun (fun_id, _) -> fun_id + | Unop _ | Binop _ -> + (* Those don't have backward functions *) + raise (Failure "Unreachable") + in + + let inst_sg = + get_instantiated_fun_sig fun_id (Some abs.back_id) type_args ctx + in + log#ldebug + (lazy + ("\n- fun_id: " ^ A.show_fun_id fun_id ^ "\n- inputs (" + ^ string_of_int (List.length inputs) + ^ "): " + ^ String.concat ", " (List.map show_texpression inputs) + ^ "\n- inst_sg.inputs (" + ^ string_of_int (List.length inst_sg.inputs) + ^ "): " + ^ String.concat ", " (List.map show_ty inst_sg.inputs))); + List.iter + (fun (x, ty) -> assert ((x : texpression).ty = ty)) + (List.combine inputs inst_sg.inputs); + log#ldebug + (lazy + ("\n- outputs: " + ^ string_of_int (List.length outputs) + ^ "\n- expected outputs: " + ^ string_of_int (List.length inst_sg.doutputs))); + List.iter + (fun (x, ty) -> assert ((x : typed_pattern).ty = ty)) + (List.combine outputs inst_sg.doutputs); + (* Retrieve the function id, and register the function call in the context + * if necessary *) + let ctx, func = bs_ctx_register_backward_call abs back_inputs ctx in + (* Translate the next expression *) + let next_e = translate_expression config e ctx in + (* Put everything together *) + let args_mplaces = List.map (fun _ -> None) inputs in + let args = + List.map + (fun (arg, mp) -> mk_opt_mplace_texpression mp arg) + (List.combine inputs args_mplaces) + in + let effect_info = + get_fun_effect_info ctx.fun_context.fun_infos fun_id (Some abs.back_id) + in + let input_tys = (List.map (fun (x : texpression) -> x.ty)) args in + let ret_ty = + if effect_info.can_fail then mk_result_ty output.ty else output.ty + in + let func_ty = mk_arrows input_tys ret_ty in + let func = { id = Func func; type_args } in + let func = { e = Qualif func; ty = func_ty } in + let call = mk_apps func args in + (* **Optimization**: + * ================= + * We do a small optimization here: if the backward function doesn't + * have any output, we don't introduce any function call. + * See the comment in [config]. + *) + if config.filter_useless_back_calls && outputs = [] then ( + (* No outputs - we do a small sanity check: the backward function + * should have exactly the same number of inputs as the forward: + * this number can be different only if the forward function returned + * a value containing mutable borrows, which can't be the case... *) + assert (List.length inputs = List.length fwd_inputs); + next_e) + else mk_let effect_info.can_fail output call next_e + | V.SynthRet -> + (* If we end the abstraction which consumed the return value of the function + we are synthesizing, we get back the borrows which were inside. Those borrows + are actually input arguments of the backward function we are synthesizing. + So we simply need to introduce proper let bindings. + + For instance: + {[ + fn id<'a>(x : &'a mut u32) -> &'a mut u32 { + x + } + ]} + + Upon ending the return abstraction for 'a, we get back the borrow for [x]. + This new value is the second argument of the backward function: + {[ + let id_back x nx = nx + ]} + + In practice, upon ending this abstraction we introduce a useless + let-binding: + {[ + let id_back x nx = + let s = nx in // the name [s] is not important (only collision matters) + ... + ]} + + This let-binding later gets inlined, during a micro-pass. + *) + (* First, retrieve the list of variables used for the inputs for the + * backward function *) + let inputs = T.RegionGroupId.Map.find abs.back_id ctx.backward_inputs in + (* Retrieve the values consumed upon ending the loans inside this + * abstraction: as there are no nested borrows, there should be none. *) + let consumed = abs_to_consumed ctx abs in + assert (consumed = []); + (* Retrieve the values given back upon ending this abstraction - note that + * we don't provide meta-place information, because those assignments will + * be inlined anyway... *) + log#ldebug (lazy ("abs: " ^ abs_to_string ctx abs)); + let ctx, given_back = abs_to_given_back_no_mp abs ctx in + (* Link the inputs to those given back values - note that this also + * checks we have the same number of values, of course *) + let given_back_inputs = List.combine given_back inputs in + (* Sanity check *) + List.iter + (fun ((given_back, input) : typed_pattern * var) -> + log#ldebug + (lazy + ("\n- given_back ty: " + ^ ty_to_string ctx given_back.ty + ^ "\n- sig input ty: " ^ ty_to_string ctx input.ty)); + assert (given_back.ty = input.ty)) + given_back_inputs; + (* Translate the next expression *) + let next_e = translate_expression config e ctx in + (* Generate the assignments *) + let monadic = false in + List.fold_right + (fun (given_back, input_var) e -> + mk_let monadic given_back (mk_texpression_from_var input_var) e) + given_back_inputs next_e + +and translate_global_eval (config : config) (gid : A.GlobalDeclId.id) + (sval : V.symbolic_value) (e : S.expression) (ctx : bs_ctx) : texpression = + let ctx, var = fresh_var_for_symbolic_value sval ctx in + let decl = A.GlobalDeclId.Map.find gid ctx.global_context.llbc_global_decls in + let global_expr = { id = Global gid; type_args = [] } in + (* We use translate_fwd_ty to translate the global type *) + let ty = ctx_translate_fwd_ty ctx decl.ty in + let gval = { e = Qualif global_expr; ty } in + let e = translate_expression config e ctx in + mk_let false (mk_typed_pattern_from_var var None) gval e + +and translate_expansion (config : config) (p : S.mplace option) + (sv : V.symbolic_value) (exp : S.expansion) (ctx : bs_ctx) : texpression = + (* Translate the scrutinee *) + let scrutinee_var = lookup_var_for_symbolic_value sv ctx in + let scrutinee = mk_texpression_from_var scrutinee_var in + let scrutinee_mplace = translate_opt_mplace p in + (* Translate the branches *) + match exp with + | ExpandNoBranch (sexp, e) -> ( + match sexp with + | V.SeConcrete _ -> + (* Actually, we don't *register* symbolic expansions to constant + * values in the symbolic ADT *) + raise (Failure "Unreachable") + | SeMutRef (_, nsv) | SeSharedRef (_, nsv) -> + (* The (mut/shared) borrow type is extracted to identity: we thus simply + * introduce an reassignment *) + let ctx, var = fresh_var_for_symbolic_value nsv ctx in + let next_e = translate_expression config e ctx in + let monadic = false in + mk_let monadic + (mk_typed_pattern_from_var var None) + (mk_opt_mplace_texpression scrutinee_mplace scrutinee) + next_e + | SeAdt _ -> + (* Should be in the [ExpandAdt] case *) + raise (Failure "Unreachable")) + | ExpandAdt branches -> ( + (* We don't do the same thing if there is a branching or not *) + match branches with + | [] -> raise (Failure "Unreachable") + | [ (variant_id, svl, branch) ] -> ( + (* There is exactly one branch: no branching *) + let type_id, _, _ = TypesUtils.ty_as_adt sv.V.sv_ty in + let ctx, vars = fresh_vars_for_symbolic_values svl ctx in + let branch = translate_expression config branch ctx in + match type_id with + | T.AdtId adt_id -> + (* Detect if this is an enumeration or not *) + let tdef = bs_ctx_lookup_llbc_type_decl adt_id ctx in + let is_enum = type_decl_is_enum tdef in + if is_enum then + (* This is an enumeration: introduce an [ExpandEnum] let-binding *) + let variant_id = Option.get variant_id in + let lvars = + List.map (fun v -> mk_typed_pattern_from_var v None) vars + in + let lv = mk_adt_pattern scrutinee.ty variant_id lvars in + let monadic = false in + + mk_let monadic lv + (mk_opt_mplace_texpression scrutinee_mplace scrutinee) + branch + else + (* This is not an enumeration: introduce let-bindings for every + * field. + * We use the [dest] variable in order not to have to recompute + * the type of the result of the projection... *) + let adt_id, type_args = + match scrutinee.ty with + | Adt (adt_id, tys) -> (adt_id, tys) + | _ -> raise (Failure "Unreachable") + in + let gen_field_proj (field_id : FieldId.id) (dest : var) : + texpression = + let proj_kind = { adt_id; field_id } in + let qualif = { id = Proj proj_kind; type_args } in + let proj_e = Qualif qualif in + let proj_ty = mk_arrow scrutinee.ty dest.ty in + let proj = { e = proj_e; ty = proj_ty } in + mk_app proj scrutinee + in + let id_var_pairs = FieldId.mapi (fun fid v -> (fid, v)) vars in + let monadic = false in + List.fold_right + (fun (fid, var) e -> + let field_proj = gen_field_proj fid var in + mk_let monadic + (mk_typed_pattern_from_var var None) + field_proj e) + id_var_pairs branch + | T.Tuple -> + let vars = + List.map (fun x -> mk_typed_pattern_from_var x None) vars + in + let monadic = false in + mk_let monadic + (mk_simpl_tuple_pattern vars) + (mk_opt_mplace_texpression scrutinee_mplace scrutinee) + branch + | T.Assumed T.Box -> + (* There should be exactly one variable *) + let var = + match vars with + | [ v ] -> v + | _ -> raise (Failure "Unreachable") + in + (* We simply introduce an assignment - the box type is the + * identity when extracted ([box a == a]) *) + let monadic = false in + mk_let monadic + (mk_typed_pattern_from_var var None) + (mk_opt_mplace_texpression scrutinee_mplace scrutinee) + branch + | T.Assumed T.Vec -> + (* We can't expand vector values: we can access the fields only + * through the functions provided by the API (note that we don't + * know how to expand a vector, because it has a variable number + * of fields!) *) + failwith "Can't expand a vector value" + | T.Assumed T.Option -> + (* We shouldn't get there in the "one-branch" case: options have + * two variants *) + raise (Failure "Unreachable")) + | branches -> + let translate_branch (variant_id : T.VariantId.id option) + (svl : V.symbolic_value list) (branch : S.expression) : + match_branch = + (* There *must* be a variant id - otherwise there can't be several branches *) + let variant_id = Option.get variant_id in + let ctx, vars = fresh_vars_for_symbolic_values svl ctx in + let vars = + List.map (fun x -> mk_typed_pattern_from_var x None) vars + in + let pat_ty = scrutinee.ty in + let pat = mk_adt_pattern pat_ty variant_id vars in + let branch = translate_expression config branch ctx in + { pat; branch } + in + let branches = + List.map (fun (vid, svl, e) -> translate_branch vid svl e) branches + in + let e = + Switch + ( mk_opt_mplace_texpression scrutinee_mplace scrutinee, + Match branches ) + in + (* There should be at least one branch *) + let branch = List.hd branches in + let ty = branch.branch.ty in + (* Sanity check *) + assert (List.for_all (fun br -> br.branch.ty = ty) branches); + (* Return *) + { e; ty }) + | ExpandBool (true_e, false_e) -> + (* We don't need to update the context: we don't introduce any + * new values/variables *) + let true_e = translate_expression config true_e ctx in + let false_e = translate_expression config false_e ctx in + let e = + Switch + ( mk_opt_mplace_texpression scrutinee_mplace scrutinee, + If (true_e, false_e) ) + in + let ty = true_e.ty in + assert (ty = false_e.ty); + { e; ty } + | ExpandInt (int_ty, branches, otherwise) -> + let translate_branch ((v, branch_e) : V.scalar_value * S.expression) : + match_branch = + (* We don't need to update the context: we don't introduce any + * new values/variables *) + let branch = translate_expression config branch_e ctx in + let pat = mk_typed_pattern_from_constant_value (V.Scalar v) in + { pat; branch } + in + let branches = List.map translate_branch branches in + let otherwise = translate_expression config otherwise ctx in + let pat_ty = Integer int_ty in + let otherwise_pat : typed_pattern = { value = PatDummy; ty = pat_ty } in + let otherwise : match_branch = + { pat = otherwise_pat; branch = otherwise } + in + let all_branches = List.append branches [ otherwise ] in + let e = + Switch + ( mk_opt_mplace_texpression scrutinee_mplace scrutinee, + Match all_branches ) + in + let ty = otherwise.branch.ty in + assert ( + List.for_all (fun (br : match_branch) -> br.branch.ty = ty) branches); + { e; ty } + +and translate_meta (config : config) (meta : S.meta) (e : S.expression) + (ctx : bs_ctx) : texpression = + let next_e = translate_expression config e ctx in + let meta = + match meta with + | S.Assignment (lp, rv, rp) -> + let lp = translate_mplace lp in + let rv = typed_value_to_texpression ctx rv in + let rp = translate_opt_mplace rp in + Assignment (lp, rv, rp) + in + let e = Meta (meta, next_e) in + let ty = next_e.ty in + { e; ty } + +let translate_fun_decl (config : config) (ctx : bs_ctx) + (body : S.expression option) : fun_decl = + (* Translate *) + let def = ctx.fun_decl in + let bid = ctx.bid in + log#ldebug + (lazy + ("SymbolicToPure.translate_fun_decl: " + ^ Print.fun_name_to_string def.A.name + ^ " (" + ^ Print.option_to_string T.RegionGroupId.to_string bid + ^ ")")); + + (* Translate the declaration *) + let def_id = def.A.def_id in + let basename = def.name in + (* Lookup the signature *) + let signature = bs_ctx_lookup_local_function_sig def_id bid ctx in + (* Translate the body, if there is *) + let body = + match body with + | None -> None + | Some body -> + let body = translate_expression config body ctx in + (* Sanity check *) + type_check_texpression ctx body; + (* Introduce the input state, if necessary *) + let effect_info = + get_fun_effect_info ctx.fun_context.fun_infos (Regular def_id) bid + in + let input_state = + if effect_info.input_state then + [ + { + id = ctx.state_var; + basename = Some ConstStrings.state_basename; + ty = mk_state_ty; + }; + ] + else [] + in + (* Compute the list of (properly ordered) input variables *) + let backward_inputs : var list = + match bid with + | None -> [] + | Some back_id -> + let parents_ids = + list_ordered_parent_region_groups def.signature back_id + in + let backward_ids = List.append parents_ids [ back_id ] in + List.concat + (List.map + (fun id -> T.RegionGroupId.Map.find id ctx.backward_inputs) + backward_ids) + in + let inputs = + List.concat [ ctx.forward_inputs; input_state; backward_inputs ] + in + let inputs_lvs = + List.map (fun v -> mk_typed_pattern_from_var v None) inputs + in + (* Sanity check *) + log#ldebug + (lazy + ("SymbolicToPure.translate_fun_decl:" ^ "\n- forward_inputs: " + ^ String.concat ", " (List.map show_var ctx.forward_inputs) + ^ "\n- input_state: " + ^ String.concat ", " (List.map show_var input_state) + ^ "\n- backward_inputs: " + ^ String.concat ", " (List.map show_var backward_inputs) + ^ "\n- signature.inputs: " + ^ String.concat ", " (List.map show_ty signature.inputs))); + assert ( + List.for_all + (fun (var, ty) -> (var : var).ty = ty) + (List.combine inputs signature.inputs)); + Some { inputs; inputs_lvs; body } + in + (* Assemble the declaration *) + let def = + { + def_id; + back_id = bid; + basename; + signature; + is_global_decl_body = def.is_global_decl_body; + body; + } + in + (* Debugging *) + log#ldebug + (lazy + ("SymbolicToPure.translate_fun_decl: translated:\n" + ^ fun_decl_to_string ctx def)); + (* return *) + def + +let translate_type_decls (type_decls : T.type_decl list) : type_decl list = + List.map translate_type_decl type_decls + +(** Translates function signatures. + + Takes as input a list of function information containing: + - the function id + - a list of optional names for the inputs + - the function signature + + Returns a map from forward/backward functions identifiers to: + - translated function signatures + - optional names for the outputs values (we derive them for the backward + functions) + *) +let translate_fun_signatures (fun_infos : FA.fun_info A.FunDeclId.Map.t) + (types_infos : TA.type_infos) + (functions : (A.fun_id * string option list * A.fun_sig) list) : + fun_sig_named_outputs RegularFunIdMap.t = + (* For every function, translate the signatures of: + - the forward function + - the backward functions + *) + let translate_one (fun_id : A.fun_id) (input_names : string option list) + (sg : A.fun_sig) : (regular_fun_id * fun_sig_named_outputs) list = + (* The forward function *) + let fwd_sg = + translate_fun_sig fun_infos fun_id types_infos sg input_names None + in + let fwd_id = (fun_id, None) in + (* The backward functions *) + let back_sgs = + List.map + (fun (rg : T.region_var_group) -> + let tsg = + translate_fun_sig fun_infos fun_id types_infos sg input_names + (Some rg.id) + in + let id = (fun_id, Some rg.id) in + (id, tsg)) + sg.regions_hierarchy + in + (* Return *) + (fwd_id, fwd_sg) :: back_sgs + in + let translated = + List.concat + (List.map (fun (id, names, sg) -> translate_one id names sg) functions) + in + List.fold_left + (fun m (id, sg) -> RegularFunIdMap.add id sg m) + RegularFunIdMap.empty translated diff --git a/compiler/SynthesizeSymbolic.ml b/compiler/SynthesizeSymbolic.ml new file mode 100644 index 00000000..a2256bdd --- /dev/null +++ b/compiler/SynthesizeSymbolic.ml @@ -0,0 +1,156 @@ +module C = Collections +module T = Types +module V = Values +module E = Expressions +module A = LlbcAst +open SymbolicAst + +let mk_mplace (p : E.place) (ctx : Contexts.eval_ctx) : mplace = + let bv = Contexts.ctx_lookup_binder ctx p.var_id in + { bv; projection = p.projection } + +let mk_opt_mplace (p : E.place option) (ctx : Contexts.eval_ctx) : mplace option + = + match p with None -> None | Some p -> Some (mk_mplace p ctx) + +let mk_opt_place_from_op (op : E.operand) (ctx : Contexts.eval_ctx) : + mplace option = + match op with + | E.Copy p | E.Move p -> Some (mk_mplace p ctx) + | E.Constant _ -> None + +let synthesize_symbolic_expansion (sv : V.symbolic_value) + (place : mplace option) (seel : V.symbolic_expansion option list) + (exprl : expression list option) : expression option = + match exprl with + | None -> None + | Some exprl -> + let ls = List.combine seel exprl in + (* Match on the symbolic value type to know which can of expansion happened *) + let expansion = + match sv.V.sv_ty with + | T.Bool -> ( + (* Boolean expansion: there should be two branches *) + match ls with + | [ + (Some (V.SeConcrete (V.Bool true)), true_exp); + (Some (V.SeConcrete (V.Bool false)), false_exp); + ] -> + ExpandBool (true_exp, false_exp) + | _ -> failwith "Ill-formed boolean expansion") + | T.Integer int_ty -> + (* Switch over an integer: split between the "regular" branches + and the "otherwise" branch (which should be the last branch) *) + let branches, otherwise = C.List.pop_last ls in + (* For all the regular branches, the symbolic value should have + * been expanded to a constant *) + let get_scalar (see : V.symbolic_expansion option) : V.scalar_value + = + match see with + | Some (V.SeConcrete (V.Scalar cv)) -> + assert (cv.V.int_ty = int_ty); + cv + | _ -> failwith "Unreachable" + in + let branches = + List.map (fun (see, exp) -> (get_scalar see, exp)) branches + in + (* For the otherwise branch, the symbolic value should have been left + * unchanged *) + let otherwise_see, otherwise = otherwise in + assert (otherwise_see = None); + (* Return *) + ExpandInt (int_ty, branches, otherwise) + | T.Adt (_, _, _) -> + (* Branching: it is necessarily an enumeration expansion *) + let get_variant (see : V.symbolic_expansion option) : + T.VariantId.id option * V.symbolic_value list = + match see with + | Some (V.SeAdt (vid, fields)) -> (vid, fields) + | _ -> failwith "Ill-formed branching ADT expansion" + in + let exp = + List.map + (fun (see, exp) -> + let vid, fields = get_variant see in + (vid, fields, exp)) + ls + in + ExpandAdt exp + | T.Ref (_, _, _) -> ( + (* Reference expansion: there should be one branch *) + match ls with + | [ (Some see, exp) ] -> ExpandNoBranch (see, exp) + | _ -> failwith "Ill-formed borrow expansion") + | T.TypeVar _ | Char | Never | Str | Array _ | Slice _ -> + failwith "Ill-formed symbolic expansion" + in + Some (Expansion (place, sv, expansion)) + +let synthesize_symbolic_expansion_no_branching (sv : V.symbolic_value) + (place : mplace option) (see : V.symbolic_expansion) + (expr : expression option) : expression option = + let exprl = match expr with None -> None | Some expr -> Some [ expr ] in + synthesize_symbolic_expansion sv place [ Some see ] exprl + +let synthesize_function_call (call_id : call_id) + (abstractions : V.AbstractionId.id list) (type_params : T.ety list) + (args : V.typed_value list) (args_places : mplace option list) + (dest : V.symbolic_value) (dest_place : mplace option) + (expr : expression option) : expression option = + match expr with + | None -> None + | Some expr -> + let call = + { + call_id; + abstractions; + type_params; + args; + dest; + args_places; + dest_place; + } + in + Some (FunCall (call, expr)) + +let synthesize_global_eval (gid : A.GlobalDeclId.id) (dest : V.symbolic_value) + (expr : expression option) : expression option = + match expr with None -> None | Some e -> Some (EvalGlobal (gid, dest, e)) + +let synthesize_regular_function_call (fun_id : A.fun_id) + (call_id : V.FunCallId.id) (abstractions : V.AbstractionId.id list) + (type_params : T.ety list) (args : V.typed_value list) + (args_places : mplace option list) (dest : V.symbolic_value) + (dest_place : mplace option) (expr : expression option) : expression option + = + synthesize_function_call + (Fun (fun_id, call_id)) + abstractions type_params args args_places dest dest_place expr + +let synthesize_unary_op (unop : E.unop) (arg : V.typed_value) + (arg_place : mplace option) (dest : V.symbolic_value) + (dest_place : mplace option) (expr : expression option) : expression option + = + synthesize_function_call (Unop unop) [] [] [ arg ] [ arg_place ] dest + dest_place expr + +let synthesize_binary_op (binop : E.binop) (arg0 : V.typed_value) + (arg0_place : mplace option) (arg1 : V.typed_value) + (arg1_place : mplace option) (dest : V.symbolic_value) + (dest_place : mplace option) (expr : expression option) : expression option + = + synthesize_function_call (Binop binop) [] [] [ arg0; arg1 ] + [ arg0_place; arg1_place ] dest dest_place expr + +let synthesize_end_abstraction (abs : V.abs) (expr : expression option) : + expression option = + match expr with + | None -> None + | Some expr -> Some (EndAbstraction (abs, expr)) + +let synthesize_assignment (lplace : mplace) (rvalue : V.typed_value) + (rplace : mplace option) (expr : expression option) : expression option = + match expr with + | None -> None + | Some expr -> Some (Meta (Assignment (lplace, rvalue, rplace), expr)) diff --git a/compiler/Translate.ml b/compiler/Translate.ml new file mode 100644 index 00000000..8f3b94c4 --- /dev/null +++ b/compiler/Translate.ml @@ -0,0 +1,871 @@ +open InterpreterStatements +open Interpreter +module L = Logging +module T = Types +module A = LlbcAst +module SA = SymbolicAst +module Micro = PureMicroPasses +open PureUtils +open TranslateCore + +(** The local logger *) +let log = TranslateCore.log + +type config = { + eval_config : Contexts.partial_config; + mp_config : Micro.config; + use_state : bool; + (** Controls whether we need to use a state to model the external world + (I/O, for instance). + *) + split_files : bool; + (** Controls whether we split the generated definitions between different + files for the types, clauses and functions, or if we group them in + one file. + *) + test_unit_functions : bool; + (** If true, insert tests in the generated files to check that the + unit functions normalize to [Success _]. + + For instance, in F* it generates code like this: + {[ + let _ = assert_norm (FUNCTION () = Success ()) + ]} + *) + extract_decreases_clauses : bool; + (** If [true], insert [decreases] clauses for all the recursive definitions. + + The body of such clauses must be defined by the user. + *) + extract_template_decreases_clauses : bool; + (** In order to help the user, we can generate "template" decrease clauses + (i.e., definitions with proper signatures but dummy bodies) in a + dedicated file. + *) +} + +(** The result of running the symbolic interpreter on a function: + - the list of symbolic values used for the input values + - the generated symbolic AST +*) +type symbolic_fun_translation = V.symbolic_value list * SA.expression + +(** Execute the symbolic interpreter on a function to generate a list of symbolic ASTs, + for the forward function and the backward functions. +*) +let translate_function_to_symbolics (config : C.partial_config) + (trans_ctx : trans_ctx) (fdef : A.fun_decl) : + (symbolic_fun_translation * symbolic_fun_translation list) option = + (* Debug *) + log#ldebug + (lazy + ("translate_function_to_symbolics: " + ^ Print.fun_name_to_string fdef.A.name)); + + let { type_context; fun_context; global_context } = trans_ctx in + let fun_context = { C.fun_decls = fun_context.fun_decls } in + + match fdef.body with + | None -> None + | Some _ -> + (* Evaluate *) + let synthesize = true in + let evaluate gid = + let inputs, symb = + evaluate_function_symbolic config synthesize type_context fun_context + global_context fdef gid + in + (inputs, Option.get symb) + in + (* Execute the forward function *) + let forward = evaluate None in + (* Execute the backward functions *) + let backwards = + T.RegionGroupId.mapi + (fun gid _ -> evaluate (Some gid)) + fdef.signature.regions_hierarchy + in + + (* Return *) + Some (forward, backwards) + +(** Translate a function, by generating its forward and backward translations. + + [fun_sigs]: maps the forward/backward functions to their signatures. In case + of backward functions, we also provide names for the outputs. + TODO: maybe we should introduce a record for this. +*) +let translate_function_to_pure (config : C.partial_config) + (mp_config : Micro.config) (trans_ctx : trans_ctx) + (fun_sigs : SymbolicToPure.fun_sig_named_outputs RegularFunIdMap.t) + (pure_type_decls : Pure.type_decl Pure.TypeDeclId.Map.t) (fdef : A.fun_decl) + : pure_fun_translation = + (* Debug *) + log#ldebug + (lazy + ("translate_function_to_pure: " ^ Print.fun_name_to_string fdef.A.name)); + + let { type_context; fun_context; global_context } = trans_ctx in + let def_id = fdef.def_id in + + (* Compute the symbolic ASTs, if the function is transparent *) + let symbolic_trans = translate_function_to_symbolics config trans_ctx fdef in + let symbolic_forward, symbolic_backwards = + match symbolic_trans with + | None -> (None, None) + | Some (fwd, backs) -> (Some fwd, Some backs) + in + + (* Convert the symbolic ASTs to pure ASTs: *) + + (* Initialize the context *) + let forward_sig = RegularFunIdMap.find (A.Regular def_id, None) fun_sigs in + let sv_to_var = V.SymbolicValueId.Map.empty in + let var_counter = Pure.VarId.generator_zero in + let state_var, var_counter = Pure.VarId.fresh var_counter in + let calls = V.FunCallId.Map.empty in + let abstractions = V.AbstractionId.Map.empty in + let type_context = + { + SymbolicToPure.types_infos = type_context.type_infos; + llbc_type_decls = type_context.type_decls; + type_decls = pure_type_decls; + } + in + let fun_context = + { + SymbolicToPure.llbc_fun_decls = fun_context.fun_decls; + fun_sigs; + fun_infos = fun_context.fun_infos; + } + in + let global_context = + { SymbolicToPure.llbc_global_decls = global_context.global_decls } + in + let ctx = + { + SymbolicToPure.bid = None; + (* Dummy for now *) + sg = forward_sig.sg; + (* Will need to be updated for the backward functions *) + sv_to_var; + var_counter; + state_var; + type_context; + fun_context; + global_context; + fun_decl = fdef; + forward_inputs = []; + (* Empty for now *) + backward_inputs = T.RegionGroupId.Map.empty; + (* Empty for now *) + backward_outputs = T.RegionGroupId.Map.empty; + (* Empty for now *) + calls; + abstractions; + } + in + + (* We need to initialize the input/output variables *) + let num_forward_inputs = List.length fdef.signature.inputs in + let add_forward_inputs input_svs ctx = + match fdef.body with + | None -> ctx + | Some body -> + let forward_input_vars = LlbcAstUtils.fun_body_get_input_vars body in + let forward_input_varnames = + List.map (fun (v : A.var) -> v.name) forward_input_vars + in + let input_svs = List.combine forward_input_varnames input_svs in + let ctx, forward_inputs = + SymbolicToPure.fresh_named_vars_for_symbolic_values input_svs ctx + in + { ctx with forward_inputs } + in + + (* The symbolic to pure config *) + let sp_config = + { + SymbolicToPure.filter_useless_back_calls = + mp_config.filter_useless_monadic_calls; + } + in + + (* Translate the forward function *) + let pure_forward = + match symbolic_forward with + | None -> SymbolicToPure.translate_fun_decl sp_config ctx None + | Some (fwd_svs, fwd_ast) -> + SymbolicToPure.translate_fun_decl sp_config + (add_forward_inputs fwd_svs ctx) + (Some fwd_ast) + in + + (* Translate the backward functions *) + let translate_backward (rg : T.region_var_group) : Pure.fun_decl = + (* For the backward inputs/outputs initialization: we use the fact that + * there are no nested borrows for now, and so that the region groups + * can't have parents *) + assert (rg.parents = []); + let back_id = rg.id in + + match symbolic_backwards with + | None -> + (* Initialize the context - note that the ret_ty is not really + * useful as we don't translate a body *) + let backward_sg = + RegularFunIdMap.find (A.Regular def_id, Some back_id) fun_sigs + in + let ctx = { ctx with bid = Some back_id; sg = backward_sg.sg } in + + (* Translate *) + SymbolicToPure.translate_fun_decl sp_config ctx None + | Some symbolic_backwards -> + let input_svs, symbolic = + T.RegionGroupId.nth symbolic_backwards back_id + in + let ctx = add_forward_inputs input_svs ctx in + (* TODO: the computation of the backward inputs is a bit awckward... *) + let backward_sg = + RegularFunIdMap.find (A.Regular def_id, Some back_id) fun_sigs + in + (* We need to ignore the forward inputs, and the state input (if there is) *) + let fun_info = + SymbolicToPure.get_fun_effect_info fun_context.fun_infos + (A.Regular def_id) (Some back_id) + in + let _, backward_inputs = + Collections.List.split_at backward_sg.sg.inputs + (num_forward_inputs + if fun_info.input_state then 1 else 0) + in + (* As we forbid nested borrows, the additional inputs for the backward + * functions come from the borrows in the return value of the rust function: + * we thus use the name "ret" for those inputs *) + let backward_inputs = + List.map (fun ty -> (Some "ret", ty)) backward_inputs + in + let ctx, backward_inputs = + SymbolicToPure.fresh_vars backward_inputs ctx + in + (* The outputs for the backward functions, however, come from borrows + * present in the input values of the rust function: for those we reuse + * the names of the input values. *) + let backward_outputs = + List.combine backward_sg.output_names backward_sg.sg.doutputs + in + let ctx, backward_outputs = + SymbolicToPure.fresh_vars backward_outputs ctx + in + let backward_inputs = + T.RegionGroupId.Map.singleton back_id backward_inputs + in + let backward_outputs = + T.RegionGroupId.Map.singleton back_id backward_outputs + in + + (* Put everything in the context *) + let ctx = + { + ctx with + bid = Some back_id; + sg = backward_sg.sg; + backward_inputs; + backward_outputs; + } + in + + (* Translate *) + SymbolicToPure.translate_fun_decl sp_config ctx (Some symbolic) + in + let pure_backwards = + List.map translate_backward fdef.signature.regions_hierarchy + in + + (* Return *) + (pure_forward, pure_backwards) + +let translate_module_to_pure (config : C.partial_config) + (mp_config : Micro.config) (use_state : bool) (crate : Crates.llbc_crate) : + trans_ctx * Pure.type_decl list * (bool * pure_fun_translation) list = + (* Debug *) + log#ldebug (lazy "translate_module_to_pure"); + + (* Compute the type and function contexts *) + let type_context, fun_context, global_context = + compute_type_fun_global_contexts crate + in + let fun_infos = + FA.analyze_module crate fun_context.C.fun_decls + global_context.C.global_decls use_state + in + let fun_context = { fun_decls = fun_context.fun_decls; fun_infos } in + let trans_ctx = { type_context; fun_context; global_context } in + + (* Translate all the type definitions *) + let type_decls = SymbolicToPure.translate_type_decls crate.types in + + (* Compute the type definition map *) + let type_decls_map = + Pure.TypeDeclId.Map.of_list + (List.map (fun (def : Pure.type_decl) -> (def.def_id, def)) type_decls) + in + + (* Translate all the function *signatures* *) + let assumed_sigs = + List.map + (fun (id, sg, _, _) -> + (A.Assumed id, List.map (fun _ -> None) (sg : A.fun_sig).inputs, sg)) + Assumed.assumed_infos + in + let local_sigs = + List.map + (fun (fdef : A.fun_decl) -> + let input_names = + match fdef.body with + | None -> List.map (fun _ -> None) fdef.signature.inputs + | Some body -> + List.map + (fun (v : A.var) -> v.name) + (LlbcAstUtils.fun_body_get_input_vars body) + in + (A.Regular fdef.def_id, input_names, fdef.signature)) + crate.functions + in + let sigs = List.append assumed_sigs local_sigs in + let fun_sigs = + SymbolicToPure.translate_fun_signatures fun_context.fun_infos + type_context.type_infos sigs + in + + (* Translate all the *transparent* functions *) + let pure_translations = + List.map + (translate_function_to_pure config mp_config trans_ctx fun_sigs + type_decls_map) + crate.functions + in + + (* Apply the micro-passes *) + let pure_translations = + List.map + (Micro.apply_passes_to_pure_fun_translation mp_config trans_ctx) + pure_translations + in + + (* Return *) + (trans_ctx, type_decls, pure_translations) + +(** Extraction context *) +type gen_ctx = { + crate : Crates.llbc_crate; + extract_ctx : PureToExtract.extraction_ctx; + trans_types : Pure.type_decl Pure.TypeDeclId.Map.t; + trans_funs : (bool * pure_fun_translation) A.FunDeclId.Map.t; + functions_with_decreases_clause : A.FunDeclId.Set.t; +} + +type gen_config = { + mp_config : Micro.config; + use_state : bool; + extract_types : bool; + extract_decreases_clauses : bool; + extract_template_decreases_clauses : bool; + extract_fun_decls : bool; + extract_transparent : bool; + (** If [true], extract the transparent declarations, otherwise ignore. *) + extract_opaque : bool; + (** If [true], extract the opaque declarations, otherwise ignore. *) + extract_state_type : bool; + (** If [true], generate a definition/declaration for the state type *) + interface : bool; + (** [true] if we generate an interface file, [false] otherwise. + For now, this only impacts whether we use [val] or [assume val] for the + opaque definitions. In the future, we might want to extract all the + declarations in an interface file, together with an implementation file + if needed. + *) + test_unit_functions : bool; +} + +(** Returns the pair: (has opaque type decls, has opaque fun decls) *) +let module_has_opaque_decls (ctx : gen_ctx) : bool * bool = + let has_opaque_types = + Pure.TypeDeclId.Map.exists + (fun _ (d : Pure.type_decl) -> + match d.kind with Opaque -> true | _ -> false) + ctx.trans_types + in + let has_opaque_funs = + A.FunDeclId.Map.exists + (fun _ ((_, (t_fwd, _)) : bool * pure_fun_translation) -> + Option.is_none t_fwd.body) + ctx.trans_funs + in + (has_opaque_types, has_opaque_funs) + +(** A generic utility to generate the extracted definitions: as we may want to + split the definitions between different files (or not), we can control + what is precisely extracted. + *) +let extract_definitions (fmt : Format.formatter) (config : gen_config) + (ctx : gen_ctx) : unit = + (* Export the definition groups to the file, in the proper order *) + let export_type (qualif : ExtractToFStar.type_decl_qualif) + (id : Pure.TypeDeclId.id) : unit = + (* Retrive the declaration *) + let def = Pure.TypeDeclId.Map.find id ctx.trans_types in + (* Update the qualifier, if the type is opaque *) + let is_opaque, qualif = + match def.kind with + | Enum _ | Struct _ -> (false, qualif) + | Opaque -> + let qualif = + if config.interface then ExtractToFStar.TypeVal + else ExtractToFStar.AssumeType + in + (true, qualif) + in + (* Extract, if the config instructs to do so (depending on whether the type + * is opaque or not) *) + if + (is_opaque && config.extract_opaque) + || ((not is_opaque) && config.extract_transparent) + then ExtractToFStar.extract_type_decl ctx.extract_ctx fmt qualif def + in + + (* Utility to check a function has a decrease clause *) + let has_decreases_clause (def : Pure.fun_decl) : bool = + A.FunDeclId.Set.mem def.def_id ctx.functions_with_decreases_clause + in + + (* In case of (non-mutually) recursive functions, we use a simple procedure to + * check if the forward and backward functions are mutually recursive. + *) + let export_functions (is_rec : bool) + (pure_ls : (bool * pure_fun_translation) list) : unit = + (* Concatenate the function definitions, filtering the useless forward + * functions. We also make pairs: (forward function, backward function) + * (the forward function contains useful information that we want to keep) *) + let fls = + List.concat + (List.map + (fun (keep_fwd, (fwd, back_ls)) -> + let back_ls = List.map (fun back -> (fwd, back)) back_ls in + if keep_fwd then (fwd, fwd) :: back_ls else back_ls) + pure_ls) + in + (* Extract the decrease clauses template bodies *) + if config.extract_template_decreases_clauses then + List.iter + (fun (_, (fwd, _)) -> + let has_decr_clause = has_decreases_clause fwd in + if has_decr_clause then + ExtractToFStar.extract_template_decreases_clause ctx.extract_ctx fmt + fwd) + pure_ls; + (* Extract the function definitions *) + (if config.extract_fun_decls then + (* Check if the functions are mutually recursive - this really works + * to check if the forward and backward translations of a single + * recursive function are mutually recursive *) + let is_mut_rec = + if is_rec then + if List.length pure_ls <= 1 then + not (PureUtils.functions_not_mutually_recursive (List.map fst fls)) + else true + else false + in + List.iteri + (fun i (fwd_def, def) -> + let is_opaque = Option.is_none fwd_def.Pure.body in + let qualif = + if is_opaque then + if config.interface then ExtractToFStar.Val + else ExtractToFStar.AssumeVal + else if not is_rec then ExtractToFStar.Let + else if is_mut_rec then + if i = 0 then ExtractToFStar.LetRec else ExtractToFStar.And + else ExtractToFStar.LetRec + in + let has_decr_clause = + has_decreases_clause def && config.extract_decreases_clauses + in + (* Check if the definition needs to be filtered or not *) + if + ((not is_opaque) && config.extract_transparent) + || (is_opaque && config.extract_opaque) + then + ExtractToFStar.extract_fun_decl ctx.extract_ctx fmt qualif + has_decr_clause def) + fls); + (* Insert unit tests if necessary *) + if config.test_unit_functions then + List.iter + (fun (keep_fwd, (fwd, _)) -> + if keep_fwd then + ExtractToFStar.extract_unit_test_if_unit_fun ctx.extract_ctx fmt fwd) + pure_ls + in + + (* TODO: Check correct behaviour with opaque globals *) + let export_global (id : A.GlobalDeclId.id) : unit = + let global_decls = ctx.extract_ctx.trans_ctx.global_context.global_decls in + let global = A.GlobalDeclId.Map.find id global_decls in + let _, (body, body_backs) = + A.FunDeclId.Map.find global.body_id ctx.trans_funs + in + assert (List.length body_backs = 0); + + let is_opaque = Option.is_none body.Pure.body in + if + ((not is_opaque) && config.extract_transparent) + || (is_opaque && config.extract_opaque) + then + ExtractToFStar.extract_global_decl ctx.extract_ctx fmt global body + config.interface + in + + let export_state_type () : unit = + let qualif = + if config.interface then ExtractToFStar.TypeVal + else ExtractToFStar.AssumeType + in + ExtractToFStar.extract_state_type fmt ctx.extract_ctx qualif + in + + let export_decl (decl : Crates.declaration_group) : unit = + match decl with + | Type (NonRec id) -> + if config.extract_types then export_type ExtractToFStar.Type id + | Type (Rec ids) -> + (* Rk.: we shouldn't have (mutually) recursive opaque types *) + if config.extract_types then + List.iteri + (fun i id -> + let qualif = + if i = 0 then ExtractToFStar.Type else ExtractToFStar.And + in + export_type qualif id) + ids + | Fun (NonRec id) -> + (* Lookup *) + let pure_fun = A.FunDeclId.Map.find id ctx.trans_funs in + (* Translate *) + export_functions false [ pure_fun ] + | Fun (Rec ids) -> + (* General case of mutually recursive functions *) + (* Lookup *) + let pure_funs = + List.map (fun id -> A.FunDeclId.Map.find id ctx.trans_funs) ids + in + (* Translate *) + export_functions true pure_funs + | Global id -> export_global id + in + + (* If we need to export the state type: we try to export it after we defined + * the type definitions, because if the user wants to define a model for the + * type, he might want to reuse them in the state type. + * More specifically: if we extract functions, we have no choice but to define + * the state type before the functions, because they may reuse this state + * type: in this case, we define/declare it at the very beginning. Otherwise, + * we define/declare it at the very end. + *) + if config.extract_state_type && config.extract_fun_decls then + export_state_type (); + List.iter export_decl ctx.crate.declarations; + if config.extract_state_type && not config.extract_fun_decls then + export_state_type () + +let extract_file (config : gen_config) (ctx : gen_ctx) (filename : string) + (rust_module_name : string) (module_name : string) (custom_msg : string) + (custom_imports : string list) (custom_includes : string list) : unit = + (* Open the file and create the formatter *) + let out = open_out filename in + let fmt = Format.formatter_of_out_channel out in + + (* Print the headers. + * Note that we don't use the OCaml formatter for purpose: we want to control + * line insertion (we have to make sure that some instructions like [open MODULE] + * are printed on one line!). + * This is ok as long as we end up with a line break, so that the formatter's + * internal count is consistent with the state of the file. + *) + (* Create the header *) + Printf.fprintf out "(** THIS FILE WAS AUTOMATICALLY GENERATED BY AENEAS *)\n"; + Printf.fprintf out "(** [%s]%s *)\n" rust_module_name custom_msg; + Printf.fprintf out "module %s\n" module_name; + Printf.fprintf out "open Primitives\n"; + (* Add the custom imports *) + List.iter (fun m -> Printf.fprintf out "open %s\n" m) custom_imports; + (* Add the custom includes *) + List.iter (fun m -> Printf.fprintf out "include %s\n" m) custom_includes; + (* Z3 options - note that we use fuel 1 because it its useful for the decrease clauses *) + Printf.fprintf out "\n#set-options \"--z3rlimit 50 --fuel 1 --ifuel 1\"\n"; + + (* From now onwards, we use the formatter *) + (* Set the margin *) + Format.pp_set_margin fmt 80; + + (* Create a vertical box *) + Format.pp_open_vbox fmt 0; + + (* Extract the definitions *) + extract_definitions fmt config ctx; + + (* Close the box and end the formatting *) + Format.pp_close_box fmt (); + Format.pp_print_newline fmt (); + + (* Some logging *) + log#linfo (lazy ("Generated: " ^ filename)); + + (* Flush and close the file *) + close_out out + +(** Translate a module and write the synthesized code to an output file. + TODO: rename to translate_crate + *) +let translate_module (filename : string) (dest_dir : string) (config : config) + (crate : Crates.llbc_crate) : unit = + (* Translate the module to the pure AST *) + let trans_ctx, trans_types, trans_funs = + translate_module_to_pure config.eval_config config.mp_config + config.use_state crate + in + + (* Initialize the extraction context - for now we extract only to F* *) + let names_map = + PureToExtract.initialize_names_map ExtractToFStar.fstar_names_map_init + in + let variant_concatenate_type_name = true in + let fstar_fmt = + ExtractToFStar.mk_formatter trans_ctx crate.name + variant_concatenate_type_name + in + let ctx = + { PureToExtract.trans_ctx; names_map; fmt = fstar_fmt; indent_incr = 2 } + in + + (* We need to compute which functions are recursive, in order to know + * whether we should generate a decrease clause or not. *) + let rec_functions = + A.FunDeclId.Set.of_list + (List.concat + (List.map + (fun decl -> + match decl with Crates.Fun (Rec ids) -> ids | _ -> []) + crate.declarations)) + in + + (* Register unique names for all the top-level types, globals and functions. + * Note that the order in which we generate the names doesn't matter: + * we just need to generate a mapping from identifier to name, and make + * sure there are no name clashes. *) + let ctx = + List.fold_left + (fun ctx def -> ExtractToFStar.extract_type_decl_register_names ctx def) + ctx trans_types + in + + let ctx = + List.fold_left + (fun ctx (keep_fwd, def) -> + (* We generate a decrease clause for all the recursive functions *) + let gen_decr_clause = + A.FunDeclId.Set.mem (fst def).Pure.def_id rec_functions + in + (* Register the names, only if the function is not a global body - + * those are handled later *) + let is_global = (fst def).Pure.is_global_decl_body in + if is_global then ctx + else + ExtractToFStar.extract_fun_decl_register_names ctx keep_fwd + gen_decr_clause def) + ctx trans_funs + in + + let ctx = + List.fold_left ExtractToFStar.extract_global_decl_register_names ctx + crate.globals + in + + (* Open the output file *) + (* First compute the filename by replacing the extension and converting the + * case (rust module names are snake case) *) + let module_name, extract_filebasename = + match Filename.chop_suffix_opt ~suffix:".llbc" filename with + | None -> + (* Note that we already checked the suffix upon opening the file *) + failwith "Unreachable" + | Some filename -> + (* Retrieve the file basename *) + let basename = Filename.basename filename in + (* Convert the case *) + let module_name = StringUtils.to_camel_case basename in + (* Concatenate *) + (module_name, Filename.concat dest_dir module_name) + in + + (* Put the translated definitions in maps *) + let trans_types = + Pure.TypeDeclId.Map.of_list + (List.map (fun (d : Pure.type_decl) -> (d.def_id, d)) trans_types) + in + let trans_funs = + A.FunDeclId.Map.of_list + (List.map + (fun ((keep_fwd, (fd, bdl)) : bool * pure_fun_translation) -> + (fd.def_id, (keep_fwd, (fd, bdl)))) + trans_funs) + in + + (* Create the directory, if necessary *) + if not (Sys.file_exists dest_dir) then ( + log#linfo (lazy ("Creating missing directory: " ^ dest_dir)); + (* Create a directory with *default* permissions *) + Core_unix.mkdir_p dest_dir); + + (* Copy "Primitives.fst" - I couldn't find a "cp" function in the OCaml + * libraries... *) + let _ = + let src = open_in "fstar/Primitives.fst" in + let tgt_filename = Filename.concat dest_dir "Primitives.fst" in + let tgt = open_out tgt_filename in + try + while true do + (* We copy line by line *) + let line = input_line src in + Printf.fprintf tgt "%s\n" line + done + with End_of_file -> + close_in src; + close_out tgt; + log#linfo (lazy ("Copied: " ^ tgt_filename)) + in + + (* Extract the file(s) *) + let gen_ctx = + { + crate; + extract_ctx = ctx; + trans_types; + trans_funs; + functions_with_decreases_clause = rec_functions; + } + in + + let use_state = config.use_state in + + (* Extract one or several files, depending on the configuration *) + if config.split_files then ( + let base_gen_config = + { + mp_config = config.mp_config; + use_state; + extract_types = false; + extract_decreases_clauses = config.extract_decreases_clauses; + extract_template_decreases_clauses = false; + extract_fun_decls = false; + extract_transparent = true; + extract_opaque = false; + extract_state_type = false; + interface = false; + test_unit_functions = false; + } + in + + (* Check if there are opaque types and functions - in which case we need + * to split *) + let has_opaque_types, has_opaque_funs = module_has_opaque_decls gen_ctx in + let has_opaque_types = has_opaque_types || use_state in + + (* Extract the types *) + (* If there are opaque types, we extract in an interface *) + let types_filename_ext = if has_opaque_types then ".fsti" else ".fst" in + let types_filename = extract_filebasename ^ ".Types" ^ types_filename_ext in + let types_module = module_name ^ ".Types" in + let types_config = + { + base_gen_config with + extract_types = true; + extract_opaque = true; + extract_state_type = use_state; + interface = has_opaque_types; + } + in + extract_file types_config gen_ctx types_filename crate.Crates.name + types_module ": type definitions" [] []; + + (* Extract the template clauses *) + let needs_clauses_module = + config.extract_decreases_clauses + && not (A.FunDeclId.Set.is_empty rec_functions) + in + (if needs_clauses_module && config.extract_template_decreases_clauses then + let clauses_filename = extract_filebasename ^ ".Clauses.Template.fst" in + let clauses_module = module_name ^ ".Clauses.Template" in + let clauses_config = + { base_gen_config with extract_template_decreases_clauses = true } + in + extract_file clauses_config gen_ctx clauses_filename crate.Crates.name + clauses_module ": templates for the decreases clauses" [ types_module ] + []); + + (* Extract the opaque functions, if needed *) + let opaque_funs_module = + if has_opaque_funs then ( + let opaque_filename = extract_filebasename ^ ".Opaque.fsti" in + let opaque_module = module_name ^ ".Opaque" in + let opaque_config = + { + base_gen_config with + extract_fun_decls = true; + extract_transparent = false; + extract_opaque = true; + interface = true; + } + in + extract_file opaque_config gen_ctx opaque_filename crate.Crates.name + opaque_module ": opaque function definitions" [] [ types_module ]; + [ opaque_module ]) + else [] + in + + (* Extract the functions *) + let fun_filename = extract_filebasename ^ ".Funs.fst" in + let fun_module = module_name ^ ".Funs" in + let fun_config = + { + base_gen_config with + extract_fun_decls = true; + test_unit_functions = config.test_unit_functions; + } + in + let clauses_module = + if needs_clauses_module then [ module_name ^ ".Clauses" ] else [] + in + extract_file fun_config gen_ctx fun_filename crate.Crates.name fun_module + ": function definitions" [] + ([ types_module ] @ opaque_funs_module @ clauses_module)) + else + let gen_config = + { + mp_config = config.mp_config; + use_state; + extract_types = true; + extract_decreases_clauses = config.extract_decreases_clauses; + extract_template_decreases_clauses = + config.extract_template_decreases_clauses; + extract_fun_decls = true; + extract_transparent = true; + extract_opaque = true; + extract_state_type = use_state; + interface = false; + test_unit_functions = config.test_unit_functions; + } + in + (* Add the extension for F* *) + let extract_filename = extract_filebasename ^ ".fst" in + extract_file gen_config gen_ctx extract_filename crate.Crates.name + module_name "" [] [] diff --git a/compiler/TranslateCore.ml b/compiler/TranslateCore.ml new file mode 100644 index 00000000..a658147d --- /dev/null +++ b/compiler/TranslateCore.ml @@ -0,0 +1,65 @@ +(** Some utilities for the translation *) + +open InterpreterStatements +module L = Logging +module T = Types +module A = LlbcAst +module SA = SymbolicAst +module FA = FunsAnalysis + +(** The local logger *) +let log = L.translate_log + +type type_context = C.type_context [@@deriving show] + +type fun_context = { + fun_decls : A.fun_decl A.FunDeclId.Map.t; + fun_infos : FA.fun_info A.FunDeclId.Map.t; +} +[@@deriving show] + +type global_context = C.global_context [@@deriving show] + +type trans_ctx = { + type_context : type_context; + fun_context : fun_context; + global_context : global_context; +} + +type pure_fun_translation = Pure.fun_decl * Pure.fun_decl list + +let type_decl_to_string (ctx : trans_ctx) (def : Pure.type_decl) : string = + let type_params = def.type_params in + let type_decls = ctx.type_context.type_decls in + let fmt = PrintPure.mk_type_formatter type_decls type_params in + PrintPure.type_decl_to_string fmt def + +let type_id_to_string (ctx : trans_ctx) (def : Pure.type_decl) : string = + let type_params = def.type_params in + let type_decls = ctx.type_context.type_decls in + let fmt = PrintPure.mk_type_formatter type_decls type_params in + PrintPure.type_decl_to_string fmt def + +let fun_sig_to_string (ctx : trans_ctx) (sg : Pure.fun_sig) : string = + let type_params = sg.type_params in + let type_decls = ctx.type_context.type_decls in + let fun_decls = ctx.fun_context.fun_decls in + let global_decls = ctx.global_context.global_decls in + let fmt = + PrintPure.mk_ast_formatter type_decls fun_decls global_decls type_params + in + PrintPure.fun_sig_to_string fmt sg + +let fun_decl_to_string (ctx : trans_ctx) (def : Pure.fun_decl) : string = + let type_params = def.signature.type_params in + let type_decls = ctx.type_context.type_decls in + let fun_decls = ctx.fun_context.fun_decls in + let global_decls = ctx.global_context.global_decls in + let fmt = + PrintPure.mk_ast_formatter type_decls fun_decls global_decls type_params + in + PrintPure.fun_decl_to_string fmt def + +let fun_decl_id_to_string (ctx : trans_ctx) (id : A.FunDeclId.id) : string = + Print.fun_name_to_string + (A.FunDeclId.Map.find id ctx.fun_context.fun_decls).name diff --git a/compiler/Types.ml b/compiler/Types.ml new file mode 100644 index 00000000..326ef76f --- /dev/null +++ b/compiler/Types.ml @@ -0,0 +1,208 @@ +open Identifiers +open Names +open Meta +module TypeVarId = IdGen () +module TypeDeclId = IdGen () +module VariantId = IdGen () +module FieldId = IdGen () + +(** Region variable ids. Used in function signatures. *) +module RegionVarId = IdGen () + +(** Region ids. Used for symbolic executions. *) +module RegionId = IdGen () + +module RegionGroupId = IdGen () + +type ('id, 'name) indexed_var = { + index : 'id; (** Unique index identifying the variable *) + name : 'name; (** Variable name *) +} +[@@deriving show] + +type type_var = (TypeVarId.id, string) indexed_var [@@deriving show] +type region_var = (RegionVarId.id, string option) indexed_var [@@deriving show] + +(** A region. + + Regions are used in function signatures (in which case we use region variable + ids) and in symbolic variables and projections (in which case we use region + ids). + *) +type 'rid region = + | Static (** Static region *) + | Var of 'rid (** Non-static region *) +[@@deriving show, ord] + +(** The type of erased regions. + + We could use unit, but having a dedicated type makes things more explicit. + *) +type erased_region = Erased [@@deriving show, ord] + +(** A group of regions. + + Results from a lifetime analysis: we group the regions with the same + lifetime together, and compute the hierarchy between the regions. + This is necessary to introduce the proper abstraction with the + proper constraints, when evaluating a function call in symbolic mode. +*) +type ('id, 'r) g_region_group = { + id : 'id; + regions : 'r list; + parents : 'id list; +} +[@@deriving show] + +type ('r, 'id) g_region_groups = ('r, 'id) g_region_group list [@@deriving show] + +type region_var_group = (RegionGroupId.id, RegionVarId.id) g_region_group +[@@deriving show] + +type region_var_groups = (RegionGroupId.id, RegionVarId.id) g_region_groups +[@@deriving show] + +type integer_type = + | Isize + | I8 + | I16 + | I32 + | I64 + | I128 + | Usize + | U8 + | U16 + | U32 + | U64 + | U128 +[@@deriving show, ord] + +let all_signed_int_types = [ Isize; I8; I16; I32; I64; I128 ] +let all_unsigned_int_types = [ Usize; U8; U16; U32; U64; U128 ] +let all_int_types = List.append all_signed_int_types all_unsigned_int_types + +type ref_kind = Mut | Shared [@@deriving show, ord] +type assumed_ty = Box | Vec | Option [@@deriving show, ord] + +(** The variant id for [Option::None] *) +let option_none_id = VariantId.of_int 0 + +(** The variant id for [Option::Some] *) +let option_some_id = VariantId.of_int 1 + +(** Type identifier for ADTs. + + ADTs are very general in our encoding: they account for "regular" ADTs, + tuples and also assumed types. +*) +type type_id = AdtId of TypeDeclId.id | Tuple | Assumed of assumed_ty +[@@deriving show, ord] + +(** Ancestor for iter visitor for [ty] *) +class ['self] iter_ty_base = + object (_self : 'self) + inherit [_] VisitorsRuntime.iter + method visit_'r : 'env -> 'r -> unit = fun _ _ -> () + method visit_id : 'env -> TypeVarId.id -> unit = fun _ _ -> () + method visit_type_id : 'env -> type_id -> unit = fun _ _ -> () + method visit_integer_type : 'env -> integer_type -> unit = fun _ _ -> () + method visit_ref_kind : 'env -> ref_kind -> unit = fun _ _ -> () + end + +(** Ancestor for map visitor for [ty] *) +class ['self] map_ty_base = + object (_self : 'self) + inherit [_] VisitorsRuntime.map + method visit_'r : 'env -> 'r -> 'r = fun _ r -> r + method visit_id : 'env -> TypeVarId.id -> TypeVarId.id = fun _ id -> id + method visit_type_id : 'env -> type_id -> type_id = fun _ id -> id + + method visit_integer_type : 'env -> integer_type -> integer_type = + fun _ ity -> ity + + method visit_ref_kind : 'env -> ref_kind -> ref_kind = fun _ rk -> rk + end + +type 'r ty = + | Adt of type_id * 'r list * 'r ty list + (** {!Adt} encodes ADTs, tuples and assumed types *) + | TypeVar of TypeVarId.id + | Bool + | Char + | Never + | Integer of integer_type + | Str + | Array of 'r ty (* TODO: there should be a constant with the array *) + | Slice of 'r ty + | Ref of 'r * 'r ty * ref_kind +[@@deriving + show, + ord, + visitors + { + name = "iter_ty"; + variety = "iter"; + ancestors = [ "iter_ty_base" ]; + nude = true (* Don't inherit {!VisitorsRuntime.iter} *); + concrete = true; + polymorphic = false; + }, + visitors + { + name = "map_ty"; + variety = "map"; + ancestors = [ "map_ty_base" ]; + nude = true (* Don't inherit {!VisitorsRuntime.iter} *); + concrete = true; + polymorphic = false; + }] +(* TODO: group Bool, Char, etc. in Constant *) + +(** Generic type with regions *) +type 'r gr_ty = 'r region ty [@@deriving show, ord] + +(** *S*ignature types. + + Used in function signatures and type definitions. + *) +type sty = RegionVarId.id gr_ty [@@deriving show, ord] + +(** Type with *R*egions. + + Used to project borrows/loans inside of abstractions, during symbolic + execution. + *) +type rty = RegionId.id gr_ty [@@deriving show, ord] + +(** Type with *E*rased regions. + + Used in function bodies, "regular" value types, etc. + *) +type ety = erased_region ty [@@deriving show, ord] + +type field = { meta : meta; field_name : string option; field_ty : sty } +[@@deriving show] + +type variant = { meta : meta; variant_name : string; fields : field list } +[@@deriving show] + +type type_decl_kind = + | Struct of field list + | Enum of variant list + | Opaque + (** An opaque type: either a local type marked as opaque, or an external type *) +[@@deriving show] + +type type_decl = { + def_id : TypeDeclId.id; + meta : meta; + name : type_name; + region_params : region_var list; + type_params : type_var list; + kind : type_decl_kind; + regions_hierarchy : region_var_groups; + (** Stores the hierarchy between the regions (which regions have the + same lifetime, which lifetime should end before which other lifetime, + etc.) *) +} +[@@deriving show] diff --git a/compiler/TypesAnalysis.ml b/compiler/TypesAnalysis.ml new file mode 100644 index 00000000..60ce5149 --- /dev/null +++ b/compiler/TypesAnalysis.ml @@ -0,0 +1,328 @@ +open Types +open Crates + +type subtype_info = { + under_borrow : bool; (** Are we inside a borrow? *) + under_mut_borrow : bool; (** Are we inside a mut borrow? *) +} +[@@deriving show] + +(** See {!type_decl_info} *) +type type_param_info = subtype_info [@@deriving show] + +type expl_info = subtype_info [@@deriving show] + +type type_borrows_info = { + contains_static : bool; + (** Does the type (transitively) contains a static borrow? *) + contains_borrow : bool; + (** Does the type (transitively) contains a borrow? *) + contains_nested_borrows : bool; + (** Does the type (transitively) contains nested borrows? *) + contains_borrow_under_mut : bool; +} +[@@deriving show] + +(** Generic definition *) +type 'p g_type_info = { + borrows_info : type_borrows_info; + (** Various informations about the borrows *) + param_infos : 'p; (** Gives information about the type parameters *) +} +[@@deriving show] + +(** Information about a type definition. *) +type type_decl_info = type_param_info list g_type_info [@@deriving show] + +(** Information about a type. *) +type ty_info = type_borrows_info [@@deriving show] + +(** Helper definition. + + Allows us to factorize code: {!analyze_full_ty} is used both to analyze + type definitions and types. *) +type partial_type_info = type_param_info list option g_type_info +[@@deriving show] + +type type_infos = type_decl_info TypeDeclId.Map.t [@@deriving show] + +let expl_info_init = { under_borrow = false; under_mut_borrow = false } + +let type_borrows_info_init : type_borrows_info = + { + contains_static = false; + contains_borrow = false; + contains_nested_borrows = false; + contains_borrow_under_mut = false; + } + +let initialize_g_type_info (param_infos : 'p) : 'p g_type_info = + { borrows_info = type_borrows_info_init; param_infos } + +let initialize_type_decl_info (def : type_decl) : type_decl_info = + let param_info = { under_borrow = false; under_mut_borrow = false } in + let param_infos = List.map (fun _ -> param_info) def.type_params in + initialize_g_type_info param_infos + +let type_decl_info_to_partial_type_info (info : type_decl_info) : + partial_type_info = + { borrows_info = info.borrows_info; param_infos = Some info.param_infos } + +let partial_type_info_to_type_decl_info (info : partial_type_info) : + type_decl_info = + { + borrows_info = info.borrows_info; + param_infos = Option.get info.param_infos; + } + +let partial_type_info_to_ty_info (info : partial_type_info) : ty_info = + info.borrows_info + +let analyze_full_ty (r_is_static : 'r -> bool) (updated : bool ref) + (infos : type_infos) (ty_info : partial_type_info) (ty : 'r ty) : + partial_type_info = + (* Small utility *) + let check_update_bool (original : bool) (nv : bool) : bool = + if nv && not original then ( + updated := true; + nv) + else original + in + + (* Update a partial_type_info, while registering if we actually performed an update *) + let update_ty_info (ty_info : partial_type_info) + (ty_b_info : type_borrows_info) : partial_type_info = + let original = ty_info.borrows_info in + let contains_static = + check_update_bool original.contains_static ty_b_info.contains_static + in + let contains_borrow = + check_update_bool original.contains_borrow ty_b_info.contains_borrow + in + let contains_nested_borrows = + check_update_bool original.contains_nested_borrows + ty_b_info.contains_nested_borrows + in + let contains_borrow_under_mut = + check_update_bool original.contains_borrow_under_mut + ty_b_info.contains_borrow_under_mut + in + let updated_borrows_info = + { + contains_static; + contains_borrow; + contains_nested_borrows; + contains_borrow_under_mut; + } + in + { ty_info with borrows_info = updated_borrows_info } + in + + (* The recursive function which explores the type *) + let rec analyze (expl_info : expl_info) (ty_info : partial_type_info) + (ty : 'r ty) : partial_type_info = + match ty with + | Bool | Char | Never | Integer _ | Str -> ty_info + | TypeVar var_id -> ( + (* Update the information for the proper parameter, if necessary *) + match ty_info.param_infos with + | None -> ty_info + | Some param_infos -> + let param_info = TypeVarId.nth param_infos var_id in + (* Set [under_borrow] *) + let under_borrow = + check_update_bool param_info.under_borrow expl_info.under_borrow + in + (* Set [under_nested_borrows] *) + let under_mut_borrow = + check_update_bool param_info.under_mut_borrow + expl_info.under_mut_borrow + in + (* Update param_info *) + let param_info = { under_borrow; under_mut_borrow } in + let param_infos = + TypeVarId.update_nth param_infos var_id param_info + in + let param_infos = Some param_infos in + { ty_info with param_infos }) + | Array ty | Slice ty -> + (* Just dive in *) + analyze expl_info ty_info ty + | Ref (r, rty, rkind) -> + (* Update the type info *) + let contains_static = r_is_static r in + let contains_borrow = true in + let contains_nested_borrows = expl_info.under_borrow in + let contains_borrow_under_mut = expl_info.under_mut_borrow in + let ty_b_info = + { + contains_static; + contains_borrow; + contains_nested_borrows; + contains_borrow_under_mut; + } + in + let ty_info = update_ty_info ty_info ty_b_info in + (* Update the exploration info *) + let expl_info = + { + under_borrow = true; + under_mut_borrow = expl_info.under_mut_borrow || rkind = Mut; + } + in + (* Continue exploring *) + analyze expl_info ty_info rty + | Adt ((Tuple | Assumed (Box | Vec | Option)), _, tys) -> + (* Nothing to update: just explore the type parameters *) + List.fold_left + (fun ty_info ty -> analyze expl_info ty_info ty) + ty_info tys + | Adt (AdtId adt_id, regions, tys) -> + (* Lookup the information for this type definition *) + let adt_info = TypeDeclId.Map.find adt_id infos in + (* Update the type info with the information from the adt *) + let ty_info = update_ty_info ty_info adt_info.borrows_info in + (* Check if 'static appears in the region parameters *) + let found_static = List.exists r_is_static regions in + let borrows_info = ty_info.borrows_info in + let borrows_info = + { + borrows_info with + contains_static = + check_update_bool borrows_info.contains_static found_static; + } + in + let ty_info = { ty_info with borrows_info } in + (* For every instantiated type parameter: update the exploration info + * then explore the type *) + let params_tys = List.combine adt_info.param_infos tys in + let ty_info = + List.fold_left + (fun ty_info (param_info, ty) -> + (* Update the type info *) + (* Below: we use only the information which we learn only + * by taking the type parameter into account. *) + let contains_static = false in + let contains_borrow = param_info.under_borrow in + let contains_nested_borrows = + expl_info.under_borrow && param_info.under_borrow + in + let contains_borrow_under_mut = + expl_info.under_mut_borrow && param_info.under_borrow + in + let ty_b_info = + { + contains_static; + contains_borrow; + contains_nested_borrows; + contains_borrow_under_mut; + } + in + let ty_info = update_ty_info ty_info ty_b_info in + (* Update the exploration info *) + let expl_info = + { + under_borrow = + expl_info.under_borrow || param_info.under_borrow; + under_mut_borrow = + expl_info.under_mut_borrow || param_info.under_mut_borrow; + } + in + (* Continue exploring *) + analyze expl_info ty_info ty) + ty_info params_tys + in + (* Return *) + ty_info + in + (* Explore *) + analyze expl_info_init ty_info ty + +let type_decl_is_opaque (d : type_decl) : bool = + match d.kind with Struct _ | Enum _ -> false | Opaque -> true + +let analyze_type_decl (updated : bool ref) (infos : type_infos) + (def : type_decl) : type_infos = + (* We analyze the type declaration only if it is not opaque (we need to explore + * the variants of the ADTs *) + if type_decl_is_opaque def then infos + else + (* Retrieve all the types of all the fields of all the variants *) + let fields_tys : sty list = + match def.kind with + | Struct fields -> List.map (fun f -> f.field_ty) fields + | Enum variants -> + List.concat + (List.map + (fun v -> List.map (fun f -> f.field_ty) v.fields) + variants) + | Opaque -> raise (Failure "unreachable") + in + (* Explore the types and accumulate information *) + let r_is_static r = r = Static in + let type_decl_info = TypeDeclId.Map.find def.def_id infos in + let type_decl_info = type_decl_info_to_partial_type_info type_decl_info in + let type_decl_info = + List.fold_left + (fun type_decl_info ty -> + analyze_full_ty r_is_static updated infos type_decl_info ty) + type_decl_info fields_tys + in + let type_decl_info = partial_type_info_to_type_decl_info type_decl_info in + (* Update the information for the type definition we explored *) + let infos = TypeDeclId.Map.add def.def_id type_decl_info infos in + (* Return *) + infos + +let analyze_type_declaration_group (type_decls : type_decl TypeDeclId.Map.t) + (infos : type_infos) (decl : type_declaration_group) : type_infos = + (* Collect the identifiers used in the declaration group *) + let ids = match decl with NonRec id -> [ id ] | Rec ids -> ids in + (* Retrieve the type definitions *) + let decl_defs = List.map (fun id -> TypeDeclId.Map.find id type_decls) ids in + (* Initialize the type information for the current definitions *) + let infos = + List.fold_left + (fun infos def -> + TypeDeclId.Map.add def.def_id (initialize_type_decl_info def) infos) + infos decl_defs + in + (* Analyze the types - this function simply computes a fixed-point *) + let updated : bool ref = ref false in + let rec analyze (infos : type_infos) : type_infos = + let infos = + List.fold_left + (fun infos def -> analyze_type_decl updated infos def) + infos decl_defs + in + if !updated then ( + updated := false; + analyze infos) + else infos + in + analyze infos + +(** Compute the type information for every *type definition* in a list of + declarations. This type definition information is later used to easily + compute the information of arbitrary types. + + Rk.: pay attention to the difference between type definitions and types! + *) +let analyze_type_declarations (type_decls : type_decl TypeDeclId.Map.t) + (decls : type_declaration_group list) : type_infos = + List.fold_left + (fun infos decl -> analyze_type_declaration_group type_decls infos decl) + TypeDeclId.Map.empty decls + +(** Analyze a type to check whether it contains borrows, etc., provided + we have already analyzed the type definitions in the context. + *) +let analyze_ty (infos : type_infos) (ty : 'r ty) : ty_info = + (* We don't use [updated] but need to give it as parameter *) + let updated = ref false in + (* We don't need to compute whether the type contains 'static or not *) + let r_is_static _ = false in + let ty_info = initialize_g_type_info None in + let ty_info = analyze_full_ty r_is_static updated infos ty_info ty in + (* Convert the ty_info *) + partial_type_info_to_ty_info ty_info diff --git a/compiler/TypesUtils.ml b/compiler/TypesUtils.ml new file mode 100644 index 00000000..7531dd8b --- /dev/null +++ b/compiler/TypesUtils.ml @@ -0,0 +1,190 @@ +open Types +open Utils +module TA = TypesAnalysis + +let type_decl_is_opaque (d : type_decl) : bool = + match d.kind with Struct _ | Enum _ -> false | Opaque -> true + +(** Retrieve the list of fields for the given variant of a {!Types.type_decl}. + + Raises [Invalid_argument] if the arguments are incorrect. + *) +let type_decl_get_fields (def : type_decl) + (opt_variant_id : VariantId.id option) : field list = + match (def.kind, opt_variant_id) with + | Enum variants, Some variant_id -> (VariantId.nth variants variant_id).fields + | Struct fields, None -> fields + | _ -> + let opt_variant_id = + match opt_variant_id with None -> "None" | Some _ -> "Some" + in + raise + (Invalid_argument + ("The variant id should be [Some] if and only if the definition is \ + an enumeration:\n\ + - def: " ^ show_type_decl def ^ "\n- opt_variant_id: " + ^ opt_variant_id)) + +(** Return [true] if a {!Types.ty} is actually [unit] *) +let ty_is_unit (ty : 'r ty) : bool = + match ty with Adt (Tuple, [], []) -> true | _ -> false + +let ty_is_adt (ty : 'r ty) : bool = + match ty with Adt (_, _, _) -> true | _ -> false + +let ty_as_adt (ty : 'r ty) : type_id * 'r list * 'r ty list = + match ty with + | Adt (id, regions, tys) -> (id, regions, tys) + | _ -> failwith "Unreachable" + +let ty_is_custom_adt (ty : 'r ty) : bool = + match ty with Adt (AdtId _, _, _) -> true | _ -> false + +let ty_as_custom_adt (ty : 'r ty) : TypeDeclId.id * 'r list * 'r ty list = + match ty with + | Adt (AdtId id, regions, tys) -> (id, regions, tys) + | _ -> failwith "Unreachable" + +(** The unit type *) +let mk_unit_ty : 'r ty = Adt (Tuple, [], []) + +(** The usize type *) +let mk_usize_ty : 'r ty = Integer Usize + +(** Deconstruct a type of the form [Box<T>] to retrieve the [T] inside *) +let ty_get_box (box_ty : ety) : ety = + match box_ty with + | Adt (Assumed Box, [], [ boxed_ty ]) -> boxed_ty + | _ -> failwith "Not a boxed type" + +(** Deconstruct a type of the form [&T] or [&mut T] to retrieve the [T] (and + the borrow kind, etc.) + *) +let ty_get_ref (ty : 'r ty) : 'r * 'r ty * ref_kind = + match ty with + | Ref (r, ty, ref_kind) -> (r, ty, ref_kind) + | _ -> failwith "Not a ref type" + +let mk_ref_ty (r : 'r) (ty : 'r ty) (ref_kind : ref_kind) : 'r ty = + Ref (r, ty, ref_kind) + +(** Make a box type *) +let mk_box_ty (ty : 'r ty) : 'r ty = Adt (Assumed Box, [], [ ty ]) + +(** Make a vec type *) +let mk_vec_ty (ty : 'r ty) : 'r ty = Adt (Assumed Vec, [], [ ty ]) + +(** Check if a region is in a set of regions *) +let region_in_set (r : RegionId.id region) (rset : RegionId.Set.t) : bool = + match r with Static -> false | Var id -> RegionId.Set.mem id rset + +(** Return the set of regions in an rty *) +let rty_regions (ty : rty) : RegionId.Set.t = + let s = ref RegionId.Set.empty in + let add_region (r : RegionId.id region) = + match r with Static -> () | Var rid -> s := RegionId.Set.add rid !s + in + let obj = + object + inherit [_] iter_ty + method! visit_'r _env r = add_region r + end + in + (* Explore the type *) + obj#visit_ty () ty; + (* Return the set of accumulated regions *) + !s + +let rty_regions_intersect (ty : rty) (regions : RegionId.Set.t) : bool = + let ty_regions = rty_regions ty in + not (RegionId.Set.disjoint ty_regions regions) + +(** Convert an {!Types.ety}, containing no region variables, to an {!Types.rty} + or an {!Types.sty}. + + In practice, it is the identity. + *) +let rec ety_no_regions_to_gr_ty (ty : ety) : 'a gr_ty = + match ty with + | Adt (type_id, regions, tys) -> + assert (regions = []); + Adt (type_id, [], List.map ety_no_regions_to_gr_ty tys) + | TypeVar v -> TypeVar v + | Bool -> Bool + | Char -> Char + | Never -> Never + | Integer int_ty -> Integer int_ty + | Str -> Str + | Array ty -> Array (ety_no_regions_to_gr_ty ty) + | Slice ty -> Slice (ety_no_regions_to_gr_ty ty) + | Ref (_, _, _) -> + failwith + "Can't convert a ref with erased regions to a ref with non-erased \ + regions" + +let ety_no_regions_to_rty (ty : ety) : rty = ety_no_regions_to_gr_ty ty +let ety_no_regions_to_sty (ty : ety) : sty = ety_no_regions_to_gr_ty ty + +(** Retuns true if the type contains borrows. + + Note that we can't simply explore the type and look for regions: sometimes + we erase the lists of regions (by replacing them with [[]] when using {!Types.ety}, + and when a type uses 'static this region doesn't appear in the region parameters. + *) +let ty_has_borrows (infos : TA.type_infos) (ty : 'r ty) : bool = + let info = TA.analyze_ty infos ty in + info.TA.contains_borrow + +(** Retuns true if the type contains nested borrows. + + Note that we can't simply explore the type and look for regions: sometimes + we erase the lists of regions (by replacing them with [[]] when using {!Types.ety}, + and when a type uses 'static this region doesn't appear in the region parameters. + *) +let ty_has_nested_borrows (infos : TA.type_infos) (ty : 'r ty) : bool = + let info = TA.analyze_ty infos ty in + info.TA.contains_nested_borrows + +(** Retuns true if the type contains a borrow under a mutable borrow *) +let ty_has_borrow_under_mut (infos : TA.type_infos) (ty : 'r ty) : bool = + let info = TA.analyze_ty infos ty in + info.TA.contains_borrow_under_mut + +(** Check if a {!Types.ty} contains regions from a given set *) +let ty_has_regions_in_set (rset : RegionId.Set.t) (ty : rty) : bool = + let obj = + object + inherit [_] iter_ty as super + + method! visit_Adt env type_id regions tys = + List.iter (fun r -> if region_in_set r rset then raise Found) regions; + super#visit_Adt env type_id regions tys + + method! visit_Ref env r ty rkind = + if region_in_set r rset then raise Found + else super#visit_Ref env r ty rkind + end + in + try + obj#visit_ty () ty; + false + with Found -> true + +(** Return true if a type is "primitively copyable". + * + * "primitively copyable" means that copying instances of this type doesn't + * require calling dedicated functions defined through the Copy trait. It + * is the case for types like integers, shared borrows, etc. + * + * Generally, ADTs are not copyable. However, some of the primitive ADTs are + * like `Option`. + *) +let rec ty_is_primitively_copyable (ty : 'r ty) : bool = + match ty with + | Adt (Assumed Option, _, tys) -> List.for_all ty_is_primitively_copyable tys + | Adt ((AdtId _ | Assumed (Box | Vec)), _, _) -> false + | Adt (Tuple, _, tys) -> List.for_all ty_is_primitively_copyable tys + | TypeVar _ | Never | Str | Array _ | Slice _ -> false + | Bool | Char | Integer _ -> true + | Ref (_, _, Mut) -> false + | Ref (_, _, Shared) -> true diff --git a/compiler/Utils.ml b/compiler/Utils.ml new file mode 100644 index 00000000..a285e869 --- /dev/null +++ b/compiler/Utils.ml @@ -0,0 +1,6 @@ +exception Found +(** Utility exception + + When looking for something while exploring a term, it can be easier to + just throw an exception to signal we found what we were looking for. + *) diff --git a/compiler/Values.ml b/compiler/Values.ml new file mode 100644 index 00000000..e404f40d --- /dev/null +++ b/compiler/Values.ml @@ -0,0 +1,844 @@ +open Identifiers +open Types + +(* TODO: I often write "abstract" (value, borrow content, etc.) while I should + * write "abstraction" (because those values are not abstract, they simply are + * inside abstractions) *) + +module VarId = IdGen () +module BorrowId = IdGen () +module SymbolicValueId = IdGen () +module AbstractionId = IdGen () +module FunCallId = IdGen () + +(** A variable *) + +type big_int = Z.t + +let big_int_of_yojson (json : Yojson.Safe.t) : (big_int, string) result = + match json with + | `Int i -> Ok (Z.of_int i) + | `Intlit is -> Ok (Z.of_string is) + | _ -> Error "not an integer or an integer literal" + +let big_int_to_yojson (i : big_int) = `Intlit (Z.to_string i) + +let pp_big_int (fmt : Format.formatter) (bi : big_int) : unit = + Format.pp_print_string fmt (Z.to_string bi) + +let show_big_int (bi : big_int) : string = Z.to_string bi + +(** A scalar value + + Note that we use unbounded integers everywhere. + We then harcode the boundaries for the different types. + *) +type scalar_value = { value : big_int; int_ty : integer_type } [@@deriving show] + +(** A constant value *) +type constant_value = + | Scalar of scalar_value + | Bool of bool + | Char of char + | String of string +[@@deriving show] + +(** The kind of a symbolic value, which precises how the value was generated *) +type sv_kind = + | FunCallRet (** The value is the return value of a function call *) + | FunCallGivenBack + (** The value is a borrowed value given back by an abstraction + (happens when giving a borrow to a function: when the abstraction + introduced to model the function call ends we reintroduce a symbolic + value in the context for the value modified by the abstraction through + the borrow). + *) + | SynthInput + (** The value is an input value of the function whose body we are + currently synthesizing. + *) + | SynthRetGivenBack + (** The value is a borrowed value that the function whose body we are + synthesizing returned, and which was given back because we ended + one of the lifetimes of this function (we do this to synthesize + the backward functions). + *) + | SynthInputGivenBack + (** The value was given back upon ending one of the input abstractions *) + | Global (** The value is a global *) +[@@deriving show] + +(** A symbolic value *) +type symbolic_value = { + sv_kind : sv_kind; + sv_id : SymbolicValueId.id; + sv_ty : rty; +} +[@@deriving show] + +(** Ancestor for {!typed_value} iter visitor *) +class ['self] iter_typed_value_base = + object (_self : 'self) + inherit [_] VisitorsRuntime.iter + method visit_constant_value : 'env -> constant_value -> unit = fun _ _ -> () + method visit_erased_region : 'env -> erased_region -> unit = fun _ _ -> () + method visit_symbolic_value : 'env -> symbolic_value -> unit = fun _ _ -> () + method visit_ety : 'env -> ety -> unit = fun _ _ -> () + end + +(** Ancestor for {!typed_value} map visitor for *) +class ['self] map_typed_value_base = + object (_self : 'self) + inherit [_] VisitorsRuntime.map + + method visit_constant_value : 'env -> constant_value -> constant_value = + fun _ cv -> cv + + method visit_erased_region : 'env -> erased_region -> erased_region = + fun _ r -> r + + method visit_symbolic_value : 'env -> symbolic_value -> symbolic_value = + fun _ sv -> sv + + method visit_ety : 'env -> ety -> ety = fun _ ty -> ty + end + +(** An untyped value, used in the environments *) +type value = + | Concrete of constant_value (** Concrete (non-symbolic) value *) + | Adt of adt_value (** Enumerations and structures *) + | Bottom (** No value (uninitialized or moved value) *) + | Borrow of borrow_content (** A borrowed value *) + | Loan of loan_content (** A loaned value *) + | Symbolic of symbolic_value + (** Borrow projector over a symbolic value. + + Note that contrary to the abstraction-values case, symbolic values + appearing in regular values are interpreted as *borrow* projectors, + they can never be *loan* projectors. + *) + +and adt_value = { + variant_id : (VariantId.id option[@opaque]); + field_values : typed_value list; +} + +and borrow_content = + | SharedBorrow of mvalue * (BorrowId.id[@opaque]) + (** A shared borrow. + + We remember the shared value which was borrowed as a meta value. + This is necessary for synthesis: upon translating to "pure" values, + we can't perform any lookup because we don't have an environment + anymore. Note that it is ok to keep the shared value and copy + the shared value this way, because shared values are immutable + for as long as they are shared (i.e., as long as we can use the + shared borrow). + *) + | MutBorrow of (BorrowId.id[@opaque]) * typed_value + (** A mutably borrowed value. *) + | InactivatedMutBorrow of mvalue * (BorrowId.id[@opaque]) + (** An inactivated mut borrow. + + This is used to model {{: https://rustc-dev-guide.rust-lang.org/borrow_check/two_phase_borrows.html} two-phase borrows}. + When evaluating a two-phase mutable borrow, we first introduce an inactivated + borrow which behaves like a shared borrow, until the moment we actually *use* + the borrow: at this point, we end all the other shared borrows (or inactivated + borrows - though there shouldn't be any other inactivated borrows if the program + is well typed) of this value and replace the inactivated borrow with a + mutable borrow. + + A simple use case of two-phase borrows: + {[ + let mut v = Vec::new(); + v.push(v.len()); + ]} + + This gets desugared to (something similar to) the following MIR: + {[ + v = Vec::new(); + v1 = &mut v; + v2 = &v; // We need this borrow, but v has already been mutably borrowed! + l = Vec::len(move v2); + Vec::push(move v1, move l); // In practice, v1 gets activated only here + ]} + + The meta-value is used for the same purposes as with shared borrows, + at the exception that in case of inactivated borrows it is not + *necessary* for the synthesis: we keep it only as meta-information. + To be more precise: + - when generating the synthesized program, we may need to convert + shared borrows to pure values + - we never need to do so for inactivated borrows: such borrows must + be activated at the moment we use them (meaning we convert a *mutable* + borrow to a pure value). However, we save meta-data about the assignments, + which is used to make the code cleaner: when generating this meta-data, + we may need to convert inactivated borrows to pure values, in which + situation we convert the meta-value we stored in the inactivated + borrow. + *) + +and loan_content = + | SharedLoan of (BorrowId.Set.t[@opaque]) * typed_value + | MutLoan of (BorrowId.id[@opaque]) + (** TODO: we might want to add a set of borrow ids (useful for inactivated + borrows, and extremely useful when giving shared values to abstractions). + *) + +(** "Meta"-value: information we store for the synthesis. + + Note that we never automatically visit the meta-values with the + visitors: they really are meta information, and shouldn't be considered + as part of the environment during a symbolic execution. + + TODO: we may want to create wrappers, to prevent accidently mixing meta + values and regular values. + *) +and mvalue = typed_value + +(** "Regular" typed value (we map variables to typed values) *) +and typed_value = { value : value; ty : ety } +[@@deriving + show, + visitors + { + name = "iter_typed_value_visit_mvalue"; + variety = "iter"; + ancestors = [ "iter_typed_value_base" ]; + nude = true (* Don't inherit {!VisitorsRuntime.iter} *); + concrete = true; + }, + visitors + { + name = "map_typed_value_visit_mvalue"; + variety = "map"; + ancestors = [ "map_typed_value_base" ]; + nude = true (* Don't inherit {!VisitorsRuntime.iter} *); + concrete = true; + }] + +(** We have to override the {!iter_typed_value_visit_mvalue.visit_mvalue} method, + to ignore meta-values *) +class ['self] iter_typed_value = + object (_self : 'self) + inherit [_] iter_typed_value_visit_mvalue + method! visit_mvalue : 'env -> mvalue -> unit = fun _ _ -> () + end + +(** We have to override the {!iter_typed_value_visit_mvalue.visit_mvalue} method, + to ignore meta-values *) +class ['self] map_typed_value = + object (_self : 'self) + inherit [_] map_typed_value_visit_mvalue + method! visit_mvalue : 'env -> mvalue -> mvalue = fun _ x -> x + end + +(** "Meta"-symbolic value. + + See the explanations for {!mvalue} + + TODO: we may want to create wrappers, to prevent mixing meta values + and regular values. + *) +type msymbolic_value = symbolic_value [@@deriving show] + +(** When giving shared borrows to functions (i.e., inserting shared borrows inside + abstractions) we need to reborrow the shared values. When doing so, we lookup + the shared values and apply some special projections to the shared value + (until we can't go further, i.e., we find symbolic values which may get + expanded upon reading them later), which don't generate avalues but + sets of borrow ids and symbolic values. + + Note that as shared values can't get modified it is ok to forget the + structure of the values we projected, and only keep the set of borrows + (and symbolic values). + + TODO: we may actually need to remember the structure, in order to know + which borrows are inside which other borrows... +*) +type abstract_shared_borrow = + | AsbBorrow of (BorrowId.id[@opaque]) + | AsbProjReborrows of (symbolic_value[@opaque]) * (rty[@opaque]) +[@@deriving show] + +(** A set of abstract shared borrows *) +type abstract_shared_borrows = abstract_shared_borrow list [@@deriving show] + +(** Ancestor for {!aproj} iter visitor *) +class ['self] iter_aproj_base = + object (_self : 'self) + inherit [_] iter_typed_value + method visit_rty : 'env -> rty -> unit = fun _ _ -> () + + method visit_msymbolic_value : 'env -> msymbolic_value -> unit = + fun _ _ -> () + end + +(** Ancestor for {!aproj} map visitor *) +class ['self] map_aproj_base = + object (_self : 'self) + inherit [_] map_typed_value + method visit_rty : 'env -> rty -> rty = fun _ ty -> ty + + method visit_msymbolic_value : 'env -> msymbolic_value -> msymbolic_value = + fun _ m -> m + end + +type aproj = + | AProjLoans of symbolic_value * (msymbolic_value * aproj) list + (** A projector of loans over a symbolic value. + + Note that the borrows of a symbolic value may be spread between + different abstractions, meaning that the projector of loans might + receive *several* (symbolic) given back values. + + This is the case in the following example: + {[ + fn f<'a> (...) -> (&'a mut u32, &'a mut u32); + fn g<'b, 'c>(p : (&'b mut u32, &'c mut u32)); + + let p = f(...); + g(move p); + + // Symbolic context after the call to g: + // abs'a {'a} { [s@0 <: (&'a mut u32, &'a mut u32)] } + // + // abs'b {'b} { (s@0 <: (&'b mut u32, &'c mut u32)) } + // abs'c {'c} { (s@0 <: (&'b mut u32, &'c mut u32)) } + ]} + + Upon evaluating the call to [f], we introduce a symbolic value [s@0] + and a projector of loans (projector loans from the region 'c). + This projector will later receive two given back values: one for + 'a and one for 'b. + + We accumulate those values in the list of projections (note that + the meta value stores the value which was given back). + + We can later end the projector of loans if [s@0] is not referenced + anywhere in the context below a projector of borrows which intersects + this projector of loans. + *) + | AProjBorrows of symbolic_value * rty + (** Note that an AProjBorrows only operates on a value which is not below + a shared loan: under a shared loan, we use {!abstract_shared_borrow}. + + Also note that once given to a borrow projection, a symbolic value + can't get updated/expanded: this means that we don't need to save + any meta-value here. + *) + | AEndedProjLoans of msymbolic_value * (msymbolic_value * aproj) list + (** An ended projector of loans over a symbolic value. + + See the explanations for {!AProjLoans} + + Note that we keep the original symbolic value as a meta-value. + *) + | AEndedProjBorrows of msymbolic_value + (** The only purpose of {!AEndedProjBorrows} is to store, for synthesis + purposes, the symbolic value which was generated and given back upon + ending the borrow. + *) + | AIgnoredProjBorrows +[@@deriving + show, + visitors + { + name = "iter_aproj"; + variety = "iter"; + ancestors = [ "iter_aproj_base" ]; + nude = true (* Don't inherit {!VisitorsRuntime.iter} *); + concrete = true; + }, + visitors + { + name = "map_aproj"; + variety = "map"; + ancestors = [ "map_aproj_base" ]; + nude = true (* Don't inherit {!VisitorsRuntime.iter} *); + concrete = true; + }] + +type region = RegionVarId.id Types.region [@@deriving show] + +(** Ancestor for {!typed_avalue} iter visitor *) +class ['self] iter_typed_avalue_base = + object (_self : 'self) + inherit [_] iter_aproj + method visit_id : 'env -> BorrowId.id -> unit = fun _ _ -> () + method visit_region : 'env -> region -> unit = fun _ _ -> () + + method visit_abstract_shared_borrows + : 'env -> abstract_shared_borrows -> unit = + fun _ _ -> () + end + +(** Ancestor for {!typed_avalue} map visitor *) +class ['self] map_typed_avalue_base = + object (_self : 'self) + inherit [_] map_aproj + method visit_id : 'env -> BorrowId.id -> BorrowId.id = fun _ id -> id + method visit_region : 'env -> region -> region = fun _ r -> r + + method visit_abstract_shared_borrows + : 'env -> abstract_shared_borrows -> abstract_shared_borrows = + fun _ asb -> asb + end + +(** Abstraction values are used inside of abstractions to properly model + borrowing relations introduced by function calls. + + When calling a function, we lose information about the borrow graph: + part of it is thus "abstracted" away. +*) +type avalue = + | AConcrete of constant_value + (** TODO: remove. We actually don't use that for the synthesis, but the + meta-values. + + Note that this case is not used in the projections to keep track of the + borrow graph (because there are no borrows in "concrete" values!) but + to correctly instantiate the backward functions (we may give back some + values at different moments: we need to remember what those values were + precisely). Also note that even though avalues and values are not the + same, once values are projected to avalues, those avalues still have + the structure of the original values (this is necessary, again, to + correctly instantiate the backward functions) + *) + | AAdt of adt_avalue + | ABottom + | ALoan of aloan_content + | ABorrow of aborrow_content + | ASymbolic of aproj + | AIgnored + (** A value which doesn't contain borrows, or which borrows we + don't own and thus ignore *) + +and adt_avalue = { + variant_id : (VariantId.id option[@opaque]); + field_values : typed_avalue list; +} + +(** A loan content as stored in an abstraction. + + Note that the children avalues are independent of the parent avalues. + For instance, the child avalue contained in an {!AMutLoan} will likely + contain other, independent loans. + Keeping track of the hierarchy is not necessary to maintain the borrow graph + (which is the primary role of the abstractions), but it is necessary + to properly instantiate the backward functions when generating the pure + translation. +*) +and aloan_content = + | AMutLoan of (BorrowId.id[@opaque]) * typed_avalue + (** A mutable loan owned by an abstraction. + + Example: + ======== + {[ + fn f<'a>(...) -> &'a mut &'a mut u32; + + let px = f(...); + ]} + + We get (after some symbolic exansion): + {[ + abs0 { + a_mut_loan l0 (a_mut_loan l1) + } + px -> mut_borrow l0 (mut_borrow @s1) + ]} + *) + | ASharedLoan of (BorrowId.Set.t[@opaque]) * typed_value * typed_avalue + (** A shared loan owned by an abstraction. + + Example: + ======== + {[ + fn f<'a>(...) -> &'a u32; + + let px = f(...); + ]} + + We get: + {[ + abs0 { a_shared_loan {l0} @s0 ⊥ } + px -> shared_loan l0 + ]} + *) + | AEndedMutLoan of { + child : typed_avalue; + given_back : typed_avalue; + given_back_meta : mvalue; + } + (** An ended mutable loan in an abstraction. + We need it because abstractions must keep track of the values + we gave back to them, so that we can correctly instantiate + backward functions. + + Rk.: *DO NOT* use [visit_AEndedMutLoan]. If we update the order of + the arguments and you forget to swap them at the level of + [visit_AEndedMutLoan], you will not notice it. + + Example: + ======== + {[ + abs0 { a_mut_loan l0 ⊥ } + x -> mut_borrow l0 (U32 3) + ]} + + After ending [l0]: + + {[ + abs0 { a_ended_mut_loan { given_back = U32 3; child = ⊥; } + x -> ⊥ + ]} + *) + | AEndedSharedLoan of typed_value * typed_avalue + (** Similar to {!AEndedMutLoan} but in this case there are no avalues to + give back. We keep the shared value because it now behaves as a + "regular" value (which contains borrows we might want to end...). + *) + | AIgnoredMutLoan of (BorrowId.id[@opaque]) * typed_avalue + (** An ignored mutable loan. + + We need to keep track of ignored mutable loans, because we may have + to apply projections on the values given back to those loans (say + you have a borrow of type [&'a mut &'b mut], in the abstraction 'b, + the outer loan is ignored, however you need to keep track of it so + that when ending the borrow corresponding to 'a you can correctly + project on the inner value). + + Example: + ======== + {[ + fn f<'a,'b>(...) -> &'a mut &'b mut u32; + let x = f(...); + + > abs'a { a_mut_loan l0 (a_ignored_mut_loan l1 ⊥) } + > abs'b { a_ignored_mut_loan l0 (a_mut_loan l1 ⊥) } + > x -> mut_borrow l0 (mut_borrow l1 @s1) + ]} + *) + | AEndedIgnoredMutLoan of { + child : typed_avalue; + given_back : typed_avalue; + given_back_meta : mvalue; + } + (** Similar to {!AEndedMutLoan}, for ignored loans. + + Rk.: *DO NOT* use [visit_AEndedIgnoredMutLoan]. + See the comment for {!AEndedMutLoan}. + *) + | AIgnoredSharedLoan of typed_avalue + (** An ignored shared loan. + + Example: + ======== + {[ + fn f<'a,'b>(...) -> &'a &'b u32; + let x = f(...); + + > abs'a { a_shared_loan {l0} (shared_borrow l1) (a_ignored_shared_loan ⊥) } + > abs'b { a_ignored_shared_loan (a_shared_loan {l1} @s1 ⊥) } + > x -> shared_borrow l0 + ]} + *) + +(** Note that when a borrow content is ended, it is replaced by ⊥ (while + we need to track ended loans more precisely, especially because of their + children values). + + Note that contrary to {!aloan_content}, here the children avalues are + not independent of the parent avalues. For instance, a value + [AMutBorrow (_, AMutBorrow (_, ...)] (ignoring the types) really is + to be seen like a [mut_borrow ... (mut_borrow ...)]. + + TODO: be more precise about the ignored borrows (keep track of the borrow + ids)? +*) +and aborrow_content = + | AMutBorrow of mvalue * (BorrowId.id[@opaque]) * typed_avalue + (** A mutable borrow owned by an abstraction. + + Is used when an abstraction "consumes" borrows, when giving borrows + as arguments to a function. + + Example: + ======== + {[ + fn f<'a>(px : &'a mut u32); + + > x -> mut_loan l0 + > px -> mut_borrow l0 (U32 0) + + f(move px); + + > x -> mut_loan l0 + > px -> ⊥ + > abs0 { a_mut_borrow l0 (U32 0) } + ]} + + The meta-value stores the initial value on which the projector was + applied, which reduced to this mut borrow. This meta-information + is only used for the synthesis. + TODO: do we really use it actually? + *) + | ASharedBorrow of (BorrowId.id[@opaque]) + (** A shared borrow owned by an abstraction. + + Example: + ======== + {[ + fn f<'a>(px : &'a u32); + + > x -> shared_loan {l0} (U32 0) + > px -> shared_borrow l0 + + f(move px); + + > x -> shared_loan {l0} (U32 0) + > px -> ⊥ + > abs0 { a_shared_borrow l0 } + ]} + *) + | AIgnoredMutBorrow of BorrowId.id option * typed_avalue + (** An ignored mutable borrow. + + We need to keep track of ignored mut borrows because when ending such + borrows, we need to project the loans of the given back value to + insert them in the proper abstractions. + + Note that we need to do so only for borrows consumed by parent + abstractions (hence the optional borrow id). + + TODO: the below explanations are obsolete + + Example: + ======== + {[ + fn f<'a,'b>(ppx : &'a mut &'b mut u32); + + > x -> mut_loan l0 + > px -> mut_loan l1 + > ppx -> mut_borrow l1 (mut_borrow l0 (U32 0)) + + f(move ppx); + + > x -> mut_loan l0 + > px -> mut_loan l1 + > ppx -> ⊥ + > abs'a { a_mut_borrow l1 (a_ignored_mut_borrow None (U32 0)) } // TODO: duplication + > abs'b {parents={abs'a}} { a_ignored_mut_borrow (Some l1) (a_mut_borrow l0 (U32 0)) } + + ... // abs'a ends + + > x -> mut_loan l0 + > px -> @s0 + > ppx -> ⊥ + > abs'b { + > a_ended_ignored_mut_borrow (a_proj_loans (@s0 <: &'b mut u32)) // <-- loan projector + > (a_mut_borrow l0 (U32 0)) + > } + + ... // [@s0] gets expanded to [&mut l2 @s1] + + > x -> mut_loan l0 + > px -> &mut l2 @s1 + > ppx -> ⊥ + > abs'b { + > a_ended_ignored_mut_borrow (a_mut_loan l2) // <-- loan l2 is here + > (a_mut_borrow l0 (U32 0)) + > } + + ]} + + Note that we could use AIgnoredMutLoan in the case the borrow id is not + None, which would allow us to simplify the rules (to not have rules + to specifically handle the case of AIgnoredMutBorrow with Some borrow + id) and also remove the AEndedIgnoredMutBorrow variant. + For now, the rules are implemented and it allows us to make the avalues + more precise and clearer, so we will keep it that way. + + TODO: this is annoying, we are duplicating information. Maybe we + could introduce an "Ignored" value? We have to pay attention to + two things: + - introducing ⊥ when ignoring a value is not always possible, because + we check whether the borrowed value contains ⊥ when giving back a + borrowed value (if it is the case we give back ⊥, otherwise we + introduce a symbolic value). This is necessary when ending nested + borrows with the same lifetime: when ending the inner borrow we + actually give back a value, however when ending the outer borrow + we need to give back ⊥. + TODO: actually we don't do that anymore, we check if the borrowed + avalue contains ended regions (which is cleaner and more robust). + - we may need to remember the precise values given to the + abstraction so that we can properly call the backward functions + when generating the pure translation. + *) + | AEndedMutBorrow of msymbolic_value * typed_avalue + (** The sole purpose of {!AEndedMutBorrow} is to store the (symbolic) value + that we gave back as a meta-value, to help with the synthesis. + + We also remember the child {!avalue} because this structural information + is useful for the synthesis (but not for the symbolic execution): + in practice the child value should only contain ended borrows, ignored + values, bottom values, etc. + *) + | AEndedSharedBorrow + (** We don't really need {!AEndedSharedBorrow}: we simply want to be + precise, and not insert ⊥ when ending borrows. + *) + | AEndedIgnoredMutBorrow of { + child : typed_avalue; + given_back_loans_proj : typed_avalue; + given_back_meta : msymbolic_value; + (** [given_back_meta] is used to store the (symbolic) value we gave back + upon ending the borrow. + + Rk.: *DO NOT* use [visit_AEndedIgnoredMutLoan]. + See the comment for {!AEndedMutLoan}. + *) + } (** See the explanations for {!AIgnoredMutBorrow} *) + | AProjSharedBorrow of abstract_shared_borrows + (** A projected shared borrow. + + When giving shared borrows as arguments to function calls, we + introduce new borrows to keep track of the fact that the function + might reborrow values inside. Note that as shared values are immutable, + we don't really need to remember the structure of the shared values. + + Example: + ======== + Below, when calling [f], we need to introduce one shared borrow per + borrow in the argument. + {[ + fn f<'a,'b>(pppx : &'a &'b &'c mut u32); + + > x -> mut_loan l0 + > px -> shared_loan {l1} (mut_borrow l0 (U32 0)) + > ppx -> shared_loan {l2} (shared_borrow l1) + > pppx -> shared_borrow l2 + + f(move pppx); + + > x -> mut_loan l0 + > px -> shared_loan {l1, l3, l4} (mut_borrow l0 (U32 0)) + > ppx -> shared_loan {l2} (shared_borrow l1) + > pppx -> ⊥ + > abs'a { a_proj_shared_borrow {l2} } + > abs'b { a_proj_shared_borrow {l3} } // l3 reborrows l1 + > abs'c { a_proj_shared_borrow {l4} } // l4 reborrows l0 + ]} + *) + +(* TODO: the type of avalues doesn't make sense for loan avalues: they currently + are typed as [& (mut) T] instead of [T]... +*) +and typed_avalue = { value : avalue; ty : rty } +[@@deriving + show, + visitors + { + name = "iter_typed_avalue"; + variety = "iter"; + ancestors = [ "iter_typed_avalue_base" ]; + nude = true (* Don't inherit {!VisitorsRuntime.iter} *); + concrete = true; + }, + visitors + { + name = "map_typed_avalue"; + variety = "map"; + ancestors = [ "map_typed_avalue_base" ]; + nude = true (* Don't inherit {!VisitorsRuntime.iter} *); + concrete = true; + }] + +(** The kind of an abstraction, which keeps track of its origin *) +type abs_kind = + | FunCall (** The abstraction was introduced because of a function call *) + | SynthInput + (** The abstraction keeps track of the input values of the function + we are currently synthesizing. *) + | SynthRet + (** The abstraction "absorbed" the value returned by the function we + are currently synthesizing *) +[@@deriving show] + +(** Abstractions model the parts in the borrow graph where the borrowing relations + have been abstracted because of a function call. + + In order to model the relations between the borrows, we use "abstraction values", + which are a special kind of value. +*) +type abs = { + abs_id : (AbstractionId.id[@opaque]); + call_id : (FunCallId.id[@opaque]); + (** The identifier of the function call which introduced this + abstraction. This is not used by the symbolic execution: + this is only used for pretty-printing and debugging, in the + symbolic AST, generated by the symbolic execution. + *) + back_id : (RegionGroupId.id[@opaque]); + (** The region group id to which this abstraction is linked. + + In most situations, it gives the id of the backward function (hence + the name), but it is a bit more subtle in the case of synth input + and synth ret abstractions. + + This is not used by the symbolic execution: it is a utility for + the symbolic AST, generated by the symbolic execution. + *) + kind : (abs_kind[@opaque]); + can_end : (bool[@opaque]); + (** Controls whether the region can be ended or not. + + This allows to "pin" some regions, and is useful when generating + backward functions. + + For instance, if we have: [fn f<'a, 'b>(...) -> (&'a mut T, &'b mut T)], + when generating the backward function for 'a, we have to make sure we + don't need to end the return region for 'b (if it is the case, it means + the function doesn't borrow check). + *) + parents : (AbstractionId.Set.t[@opaque]); (** The parent abstractions *) + original_parents : (AbstractionId.id list[@opaque]); + (** The original list of parents, ordered. This is used for synthesis. *) + regions : (RegionId.Set.t[@opaque]); (** Regions owned by this abstraction *) + ancestors_regions : (RegionId.Set.t[@opaque]); + (** Union of the regions owned by this abstraction's ancestors (not + including the regions of this abstraction itself) *) + avalues : typed_avalue list; (** The values in this abstraction *) +} +[@@deriving + show, + visitors + { + name = "iter_abs"; + variety = "iter"; + ancestors = [ "iter_typed_avalue" ]; + nude = true (* Don't inherit {!VisitorsRuntime.iter} *); + concrete = true; + }, + visitors + { + name = "map_abs"; + variety = "map"; + ancestors = [ "map_typed_avalue" ]; + nude = true (* Don't inherit {!VisitorsRuntime.iter} *); + concrete = true; + }] + +(** A symbolic expansion + + A symbolic expansion doesn't represent a value, but rather an operation + that we apply to values. + + TODO: this should rather be name "expanded_symbolic" + *) +type symbolic_expansion = + | SeConcrete of constant_value + | SeAdt of (VariantId.id option * symbolic_value list) + | SeMutRef of BorrowId.id * symbolic_value + | SeSharedRef of BorrowId.Set.t * symbolic_value diff --git a/compiler/ValuesUtils.ml b/compiler/ValuesUtils.ml new file mode 100644 index 00000000..72d7abe0 --- /dev/null +++ b/compiler/ValuesUtils.ml @@ -0,0 +1,121 @@ +open Utils +open TypesUtils +open Types +open Values +module TA = TypesAnalysis + +(** Utility exception *) +exception FoundSymbolicValue of symbolic_value + +let mk_unit_value : typed_value = + { value = Adt { variant_id = None; field_values = [] }; ty = mk_unit_ty } + +let mk_typed_value (ty : ety) (value : value) : typed_value = { value; ty } +let mk_bottom (ty : ety) : typed_value = { value = Bottom; ty } + +(** Box a value *) +let mk_box_value (v : typed_value) : typed_value = + let box_ty = mk_box_ty v.ty in + let box_v = Adt { variant_id = None; field_values = [ v ] } in + mk_typed_value box_ty box_v + +let is_bottom (v : value) : bool = match v with Bottom -> true | _ -> false + +let is_symbolic (v : value) : bool = + match v with Symbolic _ -> true | _ -> false + +let as_symbolic (v : value) : symbolic_value = + match v with Symbolic s -> s | _ -> failwith "Unexpected" + +let as_mut_borrow (v : typed_value) : BorrowId.id * typed_value = + match v.value with + | Borrow (MutBorrow (bid, bv)) -> (bid, bv) + | _ -> failwith "Unexpected" + +(** Check if a value contains a borrow *) +let borrows_in_value (v : typed_value) : bool = + let obj = + object + inherit [_] iter_typed_value + method! visit_borrow_content _env _ = raise Found + end + in + (* We use exceptions *) + try + obj#visit_typed_value () v; + false + with Found -> true + +(** Check if a value contains inactivated mutable borrows *) +let inactivated_in_value (v : typed_value) : bool = + let obj = + object + inherit [_] iter_typed_value + method! visit_InactivatedMutBorrow _env _ = raise Found + end + in + (* We use exceptions *) + try + obj#visit_typed_value () v; + false + with Found -> true + +(** Check if a value contains a loan *) +let loans_in_value (v : typed_value) : bool = + let obj = + object + inherit [_] iter_typed_value + method! visit_loan_content _env _ = raise Found + end + in + (* We use exceptions *) + try + obj#visit_typed_value () v; + false + with Found -> true + +(** Check if a value contains outer loans (i.e., loans which are not in borrwed + values. *) +let outer_loans_in_value (v : typed_value) : bool = + let obj = + object + inherit [_] iter_typed_value + method! visit_loan_content _env _ = raise Found + method! visit_borrow_content _ _ = () + end + in + (* We use exceptions *) + try + obj#visit_typed_value () v; + false + with Found -> true + +let find_first_primitively_copyable_sv_with_borrows (type_infos : TA.type_infos) + (v : typed_value) : symbolic_value option = + (* The visitor *) + let obj = + object + inherit [_] iter_typed_value + + method! visit_Symbolic _ sv = + let ty = sv.sv_ty in + if ty_is_primitively_copyable ty && ty_has_borrows type_infos ty then + raise (FoundSymbolicValue sv) + else () + end + in + (* Small helper *) + try + obj#visit_typed_value () v; + None + with FoundSymbolicValue sv -> Some sv + +(** Strip the outer shared loans in a value. + Ex.: + [shared_loan {l0, l1} (3 : u32, shared_loan {l2} (4 : u32))] ~~> + [(3 : u32, shared_loan {l2} (4 : u32))] + *) +let rec value_strip_shared_loans (v : typed_value) : typed_value = + match v.value with + | Loan (SharedLoan (_, v')) -> value_strip_shared_loans v' + | _ -> v diff --git a/compiler/aeneas.opam b/compiler/aeneas.opam new file mode 100644 index 00000000..4048f9a0 --- /dev/null +++ b/compiler/aeneas.opam @@ -0,0 +1,29 @@ +# This file is generated by dune, edit dune-project instead +opam-version: "2.0" +version: "0.1" +synopsis: "" +description: "" +maintainer: ["son.ho@inria.fr"] +authors: ["Son Ho" "Jonathan Protzenko" "Aymeric Fromherz" "Sidney Congard"] +license: "Apache-2.0" +homepage: "https://github.com/AeneasVerif/aeneas" +bug-reports: "https://github.com/AeneasVerif/aeneas/issues" +depends: [ + "dune" {>= "2.8"} + "odoc" {with-doc} +] +build: [ + ["dune" "subst"] {dev} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "@install" + "@runtest" {with-test} + "@doc" {with-doc} + ] +] +dev-repo: "git+https://github.com/AeneasVerif/aeneas.git" diff --git a/compiler/driver.ml b/compiler/driver.ml new file mode 100644 index 00000000..ae9d238a --- /dev/null +++ b/compiler/driver.ml @@ -0,0 +1,208 @@ +open Aeneas.LlbcOfJson +open Aeneas.Logging +open Aeneas.Print +module T = Aeneas.Types +module A = Aeneas.LlbcAst +module I = Aeneas.Interpreter +module EL = Easy_logging.Logging +module TA = Aeneas.TypesAnalysis +module Micro = Aeneas.PureMicroPasses +module Print = Aeneas.Print +module PrePasses = Aeneas.PrePasses +module Translate = Aeneas.Translate + +(* This is necessary to have a backtrace when raising exceptions - for some + * reason, the -g option doesn't work. + * TODO: run with OCAMLRUNPARAM=b=1? *) +let () = Printexc.record_backtrace true + +let usage = + Printf.sprintf + {|Aeneas: verification of Rust programs by translation to pure lambda calculus + +Usage: %s [OPTIONS] FILE +|} + Sys.argv.(0) + +let () = + (* Measure start time *) + let start_time = Unix.gettimeofday () in + + (* Read the command line arguments *) + let dest_dir = ref "" in + let decompose_monads = ref false in + let unfold_monads = ref true in + let filter_useless_calls = ref true in + let filter_useless_functions = ref true in + let test_units = ref false in + let test_trans_units = ref false in + let no_decreases_clauses = ref false in + let no_state = ref false in + let template_decreases_clauses = ref false in + let no_split_files = ref false in + let no_check_inv = ref false in + + let spec = + [ + ("-dest", Arg.Set_string dest_dir, " Specify the output directory"); + ( "-decompose-monads", + Arg.Set decompose_monads, + " Decompose the monadic let-bindings.\n\n\ + \ Introduces a temporary variable which is later decomposed,\n\ + \ when the pattern on the left of the monadic let is not a \n\ + \ variable.\n\ + \ \n\ + \ Example:\n\ + \ `(x, y) <-- f (); ...` ~~>\n\ + \ `tmp <-- f (); let (x, y) = tmp in ...`\n\ + \ " ); + ( "-unfold-monads", + Arg.Set unfold_monads, + " Unfold the monadic let-bindings to matches" ); + ( "-filter-useless-calls", + Arg.Set filter_useless_calls, + " Filter the useless function calls, when possible" ); + ( "-filter-useless-funs", + Arg.Set filter_useless_functions, + " Filter the useless forward/backward functions" ); + ( "-test-units", + Arg.Set test_units, + " Test the unit functions with the concrete interpreter" ); + ( "-test-trans-units", + Arg.Set test_trans_units, + " Test the translated unit functions with the target theorem\n\ + \ prover's normalizer" ); + ( "-no-decreases-clauses", + Arg.Set no_decreases_clauses, + " Do not add decrease clauses to the recursive definitions" ); + ( "-no-state", + Arg.Set no_state, + " Do not use state-error monads, simply use error monads" ); + ( "-template-clauses", + Arg.Set template_decreases_clauses, + " Generate templates for the required decreases clauses, in a\n\ + \ dedicated file. Incompatible with \ + -no-decreases-clauses" ); + ( "-no-split-files", + Arg.Set no_split_files, + " Don't split the definitions between different files for types,\n\ + \ functions, etc." ); + ( "-no-check-inv", + Arg.Set no_check_inv, + " Deactivate the invariant sanity checks performed at every step of\n\ + \ evaluation. Dramatically saves speed." ); + ] + in + (* Sanity check: -template-clauses ==> not -no-decrease-clauses *) + assert ((not !no_decreases_clauses) || not !template_decreases_clauses); + + let spec = Arg.align spec in + let filenames = ref [] in + let add_filename f = filenames := f :: !filenames in + Arg.parse spec add_filename usage; + let fail () = + print_string usage; + exit 1 + in + (* Retrieve and check the filename *) + let filename = + match !filenames with + | [ f ] -> + (* TODO: update the extension *) + if not (Filename.check_suffix f ".llbc") then ( + print_string "Unrecognized file extension"; + fail ()) + else if not (Sys.file_exists f) then ( + print_string "File not found"; + fail ()) + else f + | _ -> + (* For now, we only process one file at a time *) + print_string usage; + exit 1 + in + (* Check the destination directory *) + let dest_dir = + if !dest_dir = "" then Filename.dirname filename else !dest_dir + in + + (* Set up the logging - for now we use default values - TODO: use the + * command-line arguments *) + (* By setting a level for the main_logger_handler, we filter everything *) + Easy_logging.Handlers.set_level main_logger_handler EL.Debug; + main_log#set_level EL.Info; + llbc_of_json_logger#set_level EL.Info; + pre_passes_log#set_level EL.Info; + interpreter_log#set_level EL.Info; + statements_log#set_level EL.Info; + paths_log#set_level EL.Info; + expressions_log#set_level EL.Info; + expansion_log#set_level EL.Info; + borrows_log#set_level EL.Info; + invariants_log#set_level EL.Info; + pure_utils_log#set_level EL.Info; + symbolic_to_pure_log#set_level EL.Info; + pure_micro_passes_log#set_level EL.Info; + pure_to_extract_log#set_level EL.Info; + translate_log#set_level EL.Info; + + (* Load the module *) + let json = Yojson.Basic.from_file filename in + match llbc_crate_of_json json with + | Error s -> + main_log#error "error: %s\n" s; + exit 1 + | Ok m -> + (* Logging *) + main_log#linfo (lazy ("Imported: " ^ filename)); + main_log#ldebug (lazy ("\n" ^ Print.Module.module_to_string m ^ "\n")); + + (* Apply the pre-passes *) + let m = PrePasses.apply_passes m in + + (* Some options for the execution *) + let eval_config = + { + C.check_invariants = not !no_check_inv; + greedy_expand_symbolics_with_borrows = true; + allow_bottom_below_borrow = true; + return_unit_end_abs_with_no_loans = true; + } + in + + (* Test the unit functions with the concrete interpreter *) + if !test_units then I.Test.test_unit_functions eval_config m; + + (* Evaluate the symbolic interpreter on the functions, ignoring the + * functions which contain loops - TODO: remove *) + let synthesize = true in + I.Test.test_functions_symbolic eval_config synthesize m; + + (* Translate the functions *) + let test_unit_functions = !test_trans_units in + let micro_passes_config = + { + Micro.decompose_monadic_let_bindings = !decompose_monads; + unfold_monadic_let_bindings = !unfold_monads; + filter_useless_monadic_calls = !filter_useless_calls; + filter_useless_functions = !filter_useless_functions; + } + in + let trans_config = + { + Translate.eval_config; + mp_config = micro_passes_config; + split_files = not !no_split_files; + test_unit_functions; + extract_decreases_clauses = not !no_decreases_clauses; + extract_template_decreases_clauses = !template_decreases_clauses; + use_state = not !no_state; + } + in + Translate.translate_module filename dest_dir trans_config m; + + (* Print total elapsed time *) + log#linfo + (lazy + (Printf.sprintf "Total execution time: %f seconds" + (Unix.gettimeofday () -. start_time))) diff --git a/compiler/dune b/compiler/dune new file mode 100644 index 00000000..e8b53fc5 --- /dev/null +++ b/compiler/dune @@ -0,0 +1,48 @@ +;; core: for Core.Unix.mkdir_p + +(executable + (name driver) + (public_name aeneas_driver) + (package aeneas) + (preprocess + (pps ppx_deriving.show ppx_deriving.ord visitors.ppx)) + (libraries ppx_deriving yojson zarith easy_logging core_unix aeneas) + (modules driver)) + +(library + (name aeneas) ;; The name as used in the project + (public_name aeneas) ;; The name as revealed to the projects importing this library + (preprocess + (pps ppx_deriving.show ppx_deriving.ord visitors.ppx)) + (libraries ppx_deriving yojson zarith easy_logging core_unix) + (modules Assumed Collections ConstStrings Contexts Cps Crates Errors + Expressions ExpressionsUtils ExtractToFStar FunsAnalysis Identifiers + InterpreterBorrowsCore InterpreterBorrows InterpreterExpansion + InterpreterExpressions Interpreter InterpreterPaths InterpreterProjectors + InterpreterStatements InterpreterUtils Invariants LlbcAst LlbcAstUtils + LlbcOfJson Logging Meta Names OfJsonBasic PrePasses Print PrintPure + PureMicroPasses Pure PureToExtract PureTypeCheck PureUtils Scalars + StringUtils Substitute SymbolicAst SymbolicToPure SynthesizeSymbolic + TranslateCore Translate TypesAnalysis Types TypesUtils Utils Values + ValuesUtils)) + +(documentation + (package aeneas)) + +(env + (dev + (flags + :standard + -safe-string + -g + ;-dsource + -warn-error + -5-8-9-11-14-33-20-21-26-27-39)) + (release + (flags + :standard + -safe-string + -g + ;-dsource + -warn-error + -5-8-9-11-14-33-20-21-26-27-39))) diff --git a/compiler/dune-project b/compiler/dune-project new file mode 100644 index 00000000..f8b418f2 --- /dev/null +++ b/compiler/dune-project @@ -0,0 +1,24 @@ +(lang dune 2.8) + +(name aeneas) + +(version 0.1) + +(generate_opam_files true) + +(formatting) + +(source + (uri git+https://github.com/AeneasVerif/aeneas.git)) + +(homepage "https://github.com/AeneasVerif/aeneas") + +(bug_reports "https://github.com/AeneasVerif/aeneas/issues") + +(authors + "Son Ho" + "Jonathan Protzenko" + "Aymeric Fromherz" + "Sidney Congard") + +(license Apache-2.0)
\ No newline at end of file diff --git a/compiler/fstar/Primitives.fst b/compiler/fstar/Primitives.fst new file mode 100644 index 00000000..b44fe9d1 --- /dev/null +++ b/compiler/fstar/Primitives.fst @@ -0,0 +1,286 @@ +/// This file lists primitive and assumed functions and types +module Primitives +open FStar.Mul +open FStar.List.Tot + +#set-options "--z3rlimit 15 --fuel 0 --ifuel 1" + +(*** Utilities *) +val list_update (#a : Type0) (ls : list a) (i : nat{i < length ls}) (x : a) : + ls':list a{ + length ls' = length ls /\ + index ls' i == x + } +#push-options "--fuel 1" +let rec list_update #a ls i x = + match ls with + | x' :: ls -> if i = 0 then x :: ls else x' :: list_update ls (i-1) x +#pop-options + +(*** Result *) +type result (a : Type0) : Type0 = +| Return : v:a -> result a +| Fail : result a + +// Monadic bind and return. +// Re-definining those allows us to customize the result of the monadic notations +// like: `y <-- f x;` +let return (#a : Type0) (x:a) : result a = Return x +let bind (#a #b : Type0) (m : result a) (f : a -> result b) : result b = + match m with + | Return x -> f x + | Fail -> Fail + +// Monadic assert(...) +let massert (b:bool) : result unit = if b then Return () else Fail + +// Normalize and unwrap a successful result (used for globals). +let eval_global (#a : Type0) (x : result a{Return? (normalize_term x)}) : a = Return?.v x + +(*** Misc *) +type char = FStar.Char.char +type string = string + +let mem_replace_fwd (a : Type0) (x : a) (y : a) : a = x +let mem_replace_back (a : Type0) (x : a) (y : a) : a = y + +(*** Scalars *) +/// Rk.: most of the following code was at least partially generated + +let isize_min : int = -9223372036854775808 +let isize_max : int = 9223372036854775807 +let i8_min : int = -128 +let i8_max : int = 127 +let i16_min : int = -32768 +let i16_max : int = 32767 +let i32_min : int = -2147483648 +let i32_max : int = 2147483647 +let i64_min : int = -9223372036854775808 +let i64_max : int = 9223372036854775807 +let i128_min : int = -170141183460469231731687303715884105728 +let i128_max : int = 170141183460469231731687303715884105727 +let usize_min : int = 0 +let usize_max : int = 4294967295 // being conservative here: [u32_max] instead of [u64_max] +let u8_min : int = 0 +let u8_max : int = 255 +let u16_min : int = 0 +let u16_max : int = 65535 +let u32_min : int = 0 +let u32_max : int = 4294967295 +let u64_min : int = 0 +let u64_max : int = 18446744073709551615 +let u128_min : int = 0 +let u128_max : int = 340282366920938463463374607431768211455 + +type scalar_ty = +| Isize +| I8 +| I16 +| I32 +| I64 +| I128 +| Usize +| U8 +| U16 +| U32 +| U64 +| U128 + +let scalar_min (ty : scalar_ty) : int = + match ty with + | Isize -> isize_min + | I8 -> i8_min + | I16 -> i16_min + | I32 -> i32_min + | I64 -> i64_min + | I128 -> i128_min + | Usize -> usize_min + | U8 -> u8_min + | U16 -> u16_min + | U32 -> u32_min + | U64 -> u64_min + | U128 -> u128_min + +let scalar_max (ty : scalar_ty) : int = + match ty with + | Isize -> isize_max + | I8 -> i8_max + | I16 -> i16_max + | I32 -> i32_max + | I64 -> i64_max + | I128 -> i128_max + | Usize -> usize_max + | U8 -> u8_max + | U16 -> u16_max + | U32 -> u32_max + | U64 -> u64_max + | U128 -> u128_max + +type scalar (ty : scalar_ty) : eqtype = x:int{scalar_min ty <= x && x <= scalar_max ty} + +let mk_scalar (ty : scalar_ty) (x : int) : result (scalar ty) = + if scalar_min ty <= x && scalar_max ty >= x then Return x else Fail + +let scalar_neg (#ty : scalar_ty) (x : scalar ty) : result (scalar ty) = mk_scalar ty (-x) + +let scalar_div (#ty : scalar_ty) (x : scalar ty) (y : scalar ty) : result (scalar ty) = + if y <> 0 then mk_scalar ty (x / y) else Fail + +/// The remainder operation +let int_rem (x : int) (y : int{y <> 0}) : int = + if x >= 0 then (x % y) else -(x % y) + +(* Checking consistency with Rust *) +let _ = assert_norm(int_rem 1 2 = 1) +let _ = assert_norm(int_rem (-1) 2 = -1) +let _ = assert_norm(int_rem 1 (-2) = 1) +let _ = assert_norm(int_rem (-1) (-2) = -1) + +let scalar_rem (#ty : scalar_ty) (x : scalar ty) (y : scalar ty) : result (scalar ty) = + if y <> 0 then mk_scalar ty (int_rem x y) else Fail + +let scalar_add (#ty : scalar_ty) (x : scalar ty) (y : scalar ty) : result (scalar ty) = + mk_scalar ty (x + y) + +let scalar_sub (#ty : scalar_ty) (x : scalar ty) (y : scalar ty) : result (scalar ty) = + mk_scalar ty (x - y) + +let scalar_mul (#ty : scalar_ty) (x : scalar ty) (y : scalar ty) : result (scalar ty) = + mk_scalar ty (x * y) + +(** Cast an integer from a [src_ty] to a [tgt_ty] *) +let scalar_cast (src_ty : scalar_ty) (tgt_ty : scalar_ty) (x : scalar src_ty) : result (scalar tgt_ty) = + mk_scalar tgt_ty x + +/// The scalar types +type isize : eqtype = scalar Isize +type i8 : eqtype = scalar I8 +type i16 : eqtype = scalar I16 +type i32 : eqtype = scalar I32 +type i64 : eqtype = scalar I64 +type i128 : eqtype = scalar I128 +type usize : eqtype = scalar Usize +type u8 : eqtype = scalar U8 +type u16 : eqtype = scalar U16 +type u32 : eqtype = scalar U32 +type u64 : eqtype = scalar U64 +type u128 : eqtype = scalar U128 + +/// Negation +let isize_neg = scalar_neg #Isize +let i8_neg = scalar_neg #I8 +let i16_neg = scalar_neg #I16 +let i32_neg = scalar_neg #I32 +let i64_neg = scalar_neg #I64 +let i128_neg = scalar_neg #I128 + +/// Division +let isize_div = scalar_div #Isize +let i8_div = scalar_div #I8 +let i16_div = scalar_div #I16 +let i32_div = scalar_div #I32 +let i64_div = scalar_div #I64 +let i128_div = scalar_div #I128 +let usize_div = scalar_div #Usize +let u8_div = scalar_div #U8 +let u16_div = scalar_div #U16 +let u32_div = scalar_div #U32 +let u64_div = scalar_div #U64 +let u128_div = scalar_div #U128 + +/// Remainder +let isize_rem = scalar_rem #Isize +let i8_rem = scalar_rem #I8 +let i16_rem = scalar_rem #I16 +let i32_rem = scalar_rem #I32 +let i64_rem = scalar_rem #I64 +let i128_rem = scalar_rem #I128 +let usize_rem = scalar_rem #Usize +let u8_rem = scalar_rem #U8 +let u16_rem = scalar_rem #U16 +let u32_rem = scalar_rem #U32 +let u64_rem = scalar_rem #U64 +let u128_rem = scalar_rem #U128 + +/// Addition +let isize_add = scalar_add #Isize +let i8_add = scalar_add #I8 +let i16_add = scalar_add #I16 +let i32_add = scalar_add #I32 +let i64_add = scalar_add #I64 +let i128_add = scalar_add #I128 +let usize_add = scalar_add #Usize +let u8_add = scalar_add #U8 +let u16_add = scalar_add #U16 +let u32_add = scalar_add #U32 +let u64_add = scalar_add #U64 +let u128_add = scalar_add #U128 + +/// Substraction +let isize_sub = scalar_sub #Isize +let i8_sub = scalar_sub #I8 +let i16_sub = scalar_sub #I16 +let i32_sub = scalar_sub #I32 +let i64_sub = scalar_sub #I64 +let i128_sub = scalar_sub #I128 +let usize_sub = scalar_sub #Usize +let u8_sub = scalar_sub #U8 +let u16_sub = scalar_sub #U16 +let u32_sub = scalar_sub #U32 +let u64_sub = scalar_sub #U64 +let u128_sub = scalar_sub #U128 + +/// Multiplication +let isize_mul = scalar_mul #Isize +let i8_mul = scalar_mul #I8 +let i16_mul = scalar_mul #I16 +let i32_mul = scalar_mul #I32 +let i64_mul = scalar_mul #I64 +let i128_mul = scalar_mul #I128 +let usize_mul = scalar_mul #Usize +let u8_mul = scalar_mul #U8 +let u16_mul = scalar_mul #U16 +let u32_mul = scalar_mul #U32 +let u64_mul = scalar_mul #U64 +let u128_mul = scalar_mul #U128 + +(*** Vector *) +type vec (a : Type0) = v:list a{length v <= usize_max} + +let vec_new (a : Type0) : vec a = assert_norm(length #a [] == 0); [] +let vec_len (a : Type0) (v : vec a) : usize = length v + +// The **forward** function shouldn't be used +let vec_push_fwd (a : Type0) (v : vec a) (x : a) : unit = () +let vec_push_back (a : Type0) (v : vec a) (x : a) : + Pure (result (vec a)) + (requires True) + (ensures (fun res -> + match res with + | Fail -> True + | Return v' -> length v' = length v + 1)) = + if length v < usize_max then begin + (**) assert_norm(length [x] == 1); + (**) append_length v [x]; + (**) assert(length (append v [x]) = length v + 1); + Return (append v [x]) + end + else Fail + +// The **forward** function shouldn't be used +let vec_insert_fwd (a : Type0) (v : vec a) (i : usize) (x : a) : result unit = + if i < length v then Return () else Fail +let vec_insert_back (a : Type0) (v : vec a) (i : usize) (x : a) : result (vec a) = + if i < length v then Return (list_update v i x) else Fail + +// The **backward** function shouldn't be used +let vec_index_fwd (a : Type0) (v : vec a) (i : usize) : result a = + if i < length v then Return (index v i) else Fail +let vec_index_back (a : Type0) (v : vec a) (i : usize) (x : a) : result unit = + if i < length v then Return () else Fail + +let vec_index_mut_fwd (a : Type0) (v : vec a) (i : usize) : result a = + if i < length v then Return (index v i) else Fail +let vec_index_mut_back (a : Type0) (v : vec a) (i : usize) (nx : a) : result (vec a) = + if i < length v then Return (list_update v i nx) else Fail + |