diff options
| author | Son Ho | 2023-11-15 22:03:21 +0100 |
|---|---|---|
| committer | Son Ho | 2023-11-15 22:03:21 +0100 |
| commit | 21e3b719f2338f4d4a65c91edc0eb83d0b22393e (patch) | |
| tree | d3cf2a846a2c5a767090dc0c418026ea8a239cad | |
| parent | 4192258b7e5e3ed034ac16a326c455fe75fe6df4 (diff) | |
Start updating the name type, cleanup the names and the module abbrevs
50 files changed, 3751 insertions, 4397 deletions
diff --git a/compiler/AssociatedTypes.ml b/compiler/AssociatedTypes.ml index 2f14f0f2..06c7827a 100644 --- a/compiler/AssociatedTypes.ml +++ b/compiler/AssociatedTypes.ml @@ -6,96 +6,93 @@ enforced by local clauses (i.e., clauses of the shape [where Trait1::T = Trait2::U]). *) -module T = Types -module TU = TypesUtils -module V = Values -module E = Expressions -module A = LlbcAst -module C = Contexts +open Types +open TypesUtils +open Values +open LlbcAst +open Contexts module Subst = Substitute module L = Logging -module UF = UnionFind -module PA = Print.EvalCtxLlbcAst (** The local logger *) let log = L.associated_types_log -let trait_type_ref_substitute (subst : Subst.subst) (r : C.trait_type_ref) : - C.trait_type_ref = - let { C.trait_ref; type_name } = r in +let trait_type_ref_substitute (subst : Subst.subst) (r : trait_type_ref) : + trait_type_ref = + let { trait_ref; type_name } = r in let trait_ref = Subst.trait_ref_substitute subst trait_ref in - { C.trait_ref; type_name } + { trait_ref; type_name } module TyOrd = struct - type t = T.ty + type t = ty - let compare = T.compare_ty - let to_string = T.show_ty - let pp_t = T.pp_ty - let show_t = T.show_ty + let compare = compare_ty + let to_string = show_ty + let pp_t = pp_ty + let show_t = show_ty end module TyMap = Collections.MakeMap (TyOrd) let compute_norm_trait_types_from_preds - (trait_type_constraints : T.trait_type_constraint list) : - T.ty C.TraitTypeRefMap.t = + (trait_type_constraints : trait_type_constraint list) : ty TraitTypeRefMap.t + = (* Compute a union-find structure by recursively exploring the predicates and clauses *) - let norm : T.ty UF.elem TyMap.t ref = ref TyMap.empty in - let get_ref (ty : T.ty) : T.ty UF.elem = + let norm : ty UnionFind.elem TyMap.t ref = ref TyMap.empty in + let get_ref (ty : ty) : ty UnionFind.elem = match TyMap.find_opt ty !norm with | Some r -> r | None -> - let r = UF.make ty in + let r = UnionFind.make ty in norm := TyMap.add ty r !norm; r in - let add_trait_type_constraint (c : T.trait_type_constraint) = + let add_trait_type_constraint (c : trait_type_constraint) = (* Sanity check: the type constraint can't make use of regions - Remark that it would be enough to only visit the field [ty] of the trait type constraint, but for safety we visit all the fields *) - assert (TU.trait_type_constraint_no_regions c); - let trait_ty = T.TTraitType (c.trait_ref, c.generics, c.type_name) in + assert (trait_type_constraint_no_regions c); + let trait_ty = TTraitType (c.trait_ref, c.generics, c.type_name) in let trait_ty_ref = get_ref trait_ty in let ty_ref = get_ref c.ty in - let new_repr = UF.get ty_ref in - let merged = UF.union trait_ty_ref ty_ref in + let new_repr = UnionFind.get ty_ref in + let merged = UnionFind.union trait_ty_ref ty_ref in (* Not sure the set operation is necessary, but I want to control which representative is chosen *) - UF.set merged new_repr + UnionFind.set merged new_repr in (* Explore the local predicates *) List.iter add_trait_type_constraint trait_type_constraints; (* TODO: explore the local clauses *) (* Compute the norm maps *) let rbindings = - List.map (fun (k, v) -> (k, UF.get v)) (TyMap.bindings !norm) + List.map (fun (k, v) -> (k, UnionFind.get v)) (TyMap.bindings !norm) in (* Filter the keys to keep only the trait type aliases *) let rbindings = List.filter_map (fun (k, v) -> match k with - | T.TTraitType (trait_ref, generics, type_name) -> - assert (generics = TypesUtils.mk_empty_generic_args); - Some ({ C.trait_ref; type_name }, v) + | TTraitType (trait_ref, generics, type_name) -> + assert (generics = empty_generic_args); + Some ({ trait_ref; type_name }, v) | _ -> None) rbindings in - C.TraitTypeRefMap.of_list rbindings + TraitTypeRefMap.of_list rbindings -let ctx_add_norm_trait_types_from_preds (ctx : C.eval_ctx) - (trait_type_constraints : T.trait_type_constraint list) : C.eval_ctx = +let ctx_add_norm_trait_types_from_preds (ctx : eval_ctx) + (trait_type_constraints : trait_type_constraint list) : eval_ctx = let norm_trait_types = compute_norm_trait_types_from_preds trait_type_constraints in - { ctx with C.norm_trait_types } + { ctx with norm_trait_types } (** A trait instance id refers to a local clause if it only uses the variants: [Self], [Clause], [ParentClause], [ItemClause] *) -let rec trait_instance_id_is_local_clause (id : T.trait_instance_id) : bool = +let rec trait_instance_id_is_local_clause (id : trait_instance_id) : bool = match id with - | T.Self | Clause _ -> true + | Self | Clause _ -> true | TraitImpl _ | BuiltinOrAuto _ | TraitRef _ | UnknownTrait _ | FnPointer _ -> false | ParentClause (id, _, _) | ItemClause (id, _, _, _) -> @@ -105,100 +102,75 @@ let rec trait_instance_id_is_local_clause (id : T.trait_instance_id) : bool = but they should be applied to types without regions. *) type norm_ctx = { - norm_trait_types : T.ty C.TraitTypeRefMap.t; - 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; - trait_decls : A.trait_decl A.TraitDeclId.Map.t; - trait_impls : A.trait_impl A.TraitImplId.Map.t; - type_vars : T.type_var list; - const_generic_vars : T.const_generic_var list; + norm_trait_types : ty TraitTypeRefMap.t; + type_decls : type_decl TypeDeclId.Map.t; + fun_decls : fun_decl FunDeclId.Map.t; + global_decls : global_decl GlobalDeclId.Map.t; + trait_decls : trait_decl TraitDeclId.Map.t; + trait_impls : trait_impl TraitImplId.Map.t; + type_vars : type_var list; + const_generic_vars : const_generic_var list; } -let norm_ctx_to_type_formatter (ctx : norm_ctx) : Print.Types.type_formatter = - let open Print in - let region_id_to_string r = PT.region_id_to_string r in - - let type_var_id_to_string vid = - (* The context may be invalid *) - match T.TypeVarId.nth_opt ctx.type_vars vid with - | None -> T.TypeVarId.to_string vid - | Some v -> v.name - in - let const_generic_var_id_to_string vid = - match T.ConstGenericVarId.nth_opt ctx.const_generic_vars vid with - | None -> T.ConstGenericVarId.to_string vid - | Some v -> v.name - in - let type_decl_id_to_string def_id = - let def = T.TypeDeclId.Map.find def_id ctx.type_decls in - name_to_string def.name - in - let global_decl_id_to_string def_id = - let def = A.GlobalDeclId.Map.find def_id ctx.global_decls in - name_to_string def.name - in - let trait_decl_id_to_string def_id = - let def = A.TraitDeclId.Map.find def_id ctx.trait_decls in - name_to_string def.name - in - let trait_impl_id_to_string def_id = - let def = A.TraitImplId.Map.find def_id ctx.trait_impls in - name_to_string def.name - in - let trait_clause_id_to_string id = PT.trait_clause_id_to_pretty_string id in +let norm_ctx_to_fmt_env (ctx : norm_ctx) : Print.fmt_env = { - region_id_to_string; - type_var_id_to_string; - type_decl_id_to_string; - const_generic_var_id_to_string; - global_decl_id_to_string; - trait_decl_id_to_string; - trait_impl_id_to_string; - trait_clause_id_to_string; + type_decls = ctx.type_decls; + fun_decls = ctx.fun_decls; + global_decls = ctx.global_decls; + trait_decls = ctx.trait_decls; + trait_impls = ctx.trait_impls; + generics = + { + types = ctx.type_vars; + const_generics = ctx.const_generic_vars; + regions = []; + trait_clauses = []; + }; + preds = empty_predicates; + locals = []; } -let norm_ctx_get_ty_repr (ctx : norm_ctx) (x : C.trait_type_ref) : T.ty option = - C.TraitTypeRefMap.find_opt x ctx.norm_trait_types +let norm_ctx_get_ty_repr (ctx : norm_ctx) (x : trait_type_ref) : ty option = + TraitTypeRefMap.find_opt x ctx.norm_trait_types -let ty_to_string (ctx : norm_ctx) (ty : T.ty) : string = - let ctx = norm_ctx_to_type_formatter ctx in +let ty_to_string (ctx : norm_ctx) (ty : ty) : string = + let ctx = norm_ctx_to_fmt_env ctx in Print.Types.ty_to_string ctx ty -let trait_ref_to_string (ctx : norm_ctx) (x : T.trait_ref) : string = - let ctx = norm_ctx_to_type_formatter ctx in +let trait_ref_to_string (ctx : norm_ctx) (x : trait_ref) : string = + let ctx = norm_ctx_to_fmt_env ctx in Print.Types.trait_ref_to_string ctx x -let trait_instance_id_to_string (ctx : norm_ctx) (x : T.trait_instance_id) : +let trait_instance_id_to_string (ctx : norm_ctx) (x : trait_instance_id) : string = - let ctx = norm_ctx_to_type_formatter ctx in + let ctx = norm_ctx_to_fmt_env ctx in Print.Types.trait_instance_id_to_string ctx x -let generic_args_to_string (ctx : norm_ctx) (x : T.generic_args) : string = - let ctx = norm_ctx_to_type_formatter ctx in +let generic_args_to_string (ctx : norm_ctx) (x : generic_args) : string = + let ctx = norm_ctx_to_fmt_env ctx in Print.Types.generic_args_to_string ctx x -let generic_params_to_string (ctx : norm_ctx) (x : T.generic_params) : string = - let ctx = norm_ctx_to_type_formatter ctx in +let generic_params_to_string (ctx : norm_ctx) (x : generic_params) : string = + let ctx = norm_ctx_to_fmt_env ctx in "<" ^ String.concat ", " (fst (Print.Types.generic_params_to_strings ctx x)) ^ ">" (** Small utility to lookup trait impls, together with a substitution. *) -let norm_ctx_lookup_trait_impl (ctx : norm_ctx) (impl_id : T.TraitImplId.id) - (generics : T.generic_args) : A.trait_impl * Subst.subst = +let norm_ctx_lookup_trait_impl (ctx : norm_ctx) (impl_id : TraitImplId.id) + (generics : generic_args) : trait_impl * Subst.subst = (* Lookup the implementation *) - let trait_impl = A.TraitImplId.Map.find impl_id ctx.trait_impls in + let trait_impl = TraitImplId.Map.find impl_id ctx.trait_impls in (* The substitution *) - let tr_self = T.UnknownTrait __FUNCTION__ in + let tr_self = UnknownTrait __FUNCTION__ in let subst = Subst.make_subst_from_generics trait_impl.generics generics tr_self in (* Return *) (trait_impl, subst) -let norm_ctx_lookup_trait_impl_ty (ctx : norm_ctx) (impl_id : T.TraitImplId.id) - (generics : T.generic_args) (type_name : string) : T.ty = +let norm_ctx_lookup_trait_impl_ty (ctx : norm_ctx) (impl_id : TraitImplId.id) + (generics : generic_args) (type_name : string) : ty = (* Lookup the implementation *) let trait_impl, subst = norm_ctx_lookup_trait_impl ctx impl_id generics in (* Lookup the type *) @@ -207,25 +179,25 @@ let norm_ctx_lookup_trait_impl_ty (ctx : norm_ctx) (impl_id : T.TraitImplId.id) Subst.ty_substitute subst ty let norm_ctx_lookup_trait_impl_parent_clause (ctx : norm_ctx) - (impl_id : T.TraitImplId.id) (generics : T.generic_args) - (clause_id : T.TraitClauseId.id) : T.trait_ref = + (impl_id : TraitImplId.id) (generics : generic_args) + (clause_id : TraitClauseId.id) : trait_ref = (* Lookup the implementation *) let trait_impl, subst = norm_ctx_lookup_trait_impl ctx impl_id generics in (* Lookup the clause *) - let clause = T.TraitClauseId.nth trait_impl.parent_trait_refs clause_id in + let clause = TraitClauseId.nth trait_impl.parent_trait_refs clause_id in (* Sanity check: the clause necessarily refers to an impl *) let _ = TypesUtils.trait_instance_id_as_trait_impl clause.trait_id in (* Substitute *) Subst.trait_ref_substitute subst clause let norm_ctx_lookup_trait_impl_item_clause (ctx : norm_ctx) - (impl_id : T.TraitImplId.id) (generics : T.generic_args) - (item_name : string) (clause_id : T.TraitClauseId.id) : T.trait_ref = + (impl_id : TraitImplId.id) (generics : generic_args) (item_name : string) + (clause_id : TraitClauseId.id) : trait_ref = (* Lookup the implementation *) let trait_impl, subst = norm_ctx_lookup_trait_impl ctx impl_id generics in (* Lookup the item then its clause *) let item = List.assoc item_name trait_impl.types in - let clause = T.TraitClauseId.nth (fst item) clause_id in + let clause = TraitClauseId.nth (fst item) clause_id in (* Sanity check: the clause necessarily refers to an impl *) let _ = TypesUtils.trait_instance_id_as_trait_impl clause.trait_id in (* Substitute *) @@ -237,15 +209,15 @@ let norm_ctx_lookup_trait_impl_item_clause (ctx : norm_ctx) See the comments for {!norm_ctx_normalize_trait_instance_id}. *) -let rec norm_ctx_normalize_ty (ctx : norm_ctx) (ty : T.ty) : T.ty = +let rec norm_ctx_normalize_ty (ctx : norm_ctx) (ty : ty) : ty = log#ldebug (lazy ("norm_ctx_normalize_ty: " ^ ty_to_string ctx ty)); match ty with - | T.TAdt (id, generics) -> + | TAdt (id, generics) -> TAdt (id, norm_ctx_normalize_generic_args ctx generics) | TVar _ | TLiteral _ | TNever -> ty | TRef (r, ty, rkind) -> let ty = norm_ctx_normalize_ty ctx ty in - T.TRef (r, ty, rkind) + TRef (r, ty, rkind) | TRawPtr (ty, rkind) -> let ty = norm_ctx_normalize_ty ctx ty in TRawPtr (ty, rkind) @@ -259,19 +231,19 @@ let rec norm_ctx_normalize_ty (ctx : norm_ctx) (ty : T.ty) : T.ty = ("norm_ctx_normalize_ty:\n- trait type: " ^ ty_to_string ctx ty ^ "\n- trait_ref: " ^ trait_ref_to_string ctx trait_ref - ^ "\n- raw trait ref:\n" ^ T.show_trait_ref trait_ref + ^ "\n- raw trait ref:\n" ^ show_trait_ref trait_ref ^ "\n- generics:\n" ^ generic_args_to_string ctx generics)); (* Normalize and attempt to project the type from the trait ref *) let trait_ref = norm_ctx_normalize_trait_ref ctx trait_ref in let generics = norm_ctx_normalize_generic_args ctx generics in (* For now, we don't support higher order types *) - assert (generics = TypesUtils.mk_empty_generic_args); - let ty : T.ty = + assert (generics = empty_generic_args); + let ty : ty = match trait_ref.trait_id with - | T.TraitRef - { T.trait_id = T.TraitImpl impl_id; generics = ref_generics; _ } -> - assert (ref_generics = TypesUtils.mk_empty_generic_args); + | TraitRef { trait_id = TraitImpl impl_id; generics = ref_generics; _ } + -> + assert (ref_generics = empty_generic_args); log#ldebug (lazy ("norm_ctx_normalize_ty: trait type: trait ref: " @@ -283,17 +255,17 @@ let rec norm_ctx_normalize_ty (ctx : norm_ctx) (ty : T.ty) : T.ty = in (* Normalize *) norm_ctx_normalize_ty ctx ty - | T.TraitImpl impl_id -> + | TraitImpl impl_id -> log#ldebug (lazy ("norm_ctx_normalize_ty (trait impl):\n- trait type: " ^ ty_to_string ctx ty ^ "\n- trait_ref: " ^ trait_ref_to_string ctx trait_ref - ^ "\n- raw trait ref:\n" ^ T.show_trait_ref trait_ref)); + ^ "\n- raw trait ref:\n" ^ show_trait_ref trait_ref)); (* This happens. This doesn't come from the substitutions performed by Aeneas (the [TraitImpl] would be wrapped in a [TraitRef] but from non-normalized traits translated from - the Rustc AST. + the Rustc AS TODO: factor out with the branch above. *) (* Lookup the type *) @@ -309,12 +281,12 @@ let rec norm_ctx_normalize_ty (ctx : norm_ctx) (ty : T.ty) : T.ty = ("norm_ctx_normalize_ty: trait type: not a trait ref: " ^ ty_to_string ctx ty ^ "\n- trait_ref: " ^ trait_ref_to_string ctx trait_ref - ^ "\n- raw trait ref:\n" ^ T.show_trait_ref trait_ref)); + ^ "\n- raw trait ref:\n" ^ show_trait_ref trait_ref)); (* We can't project *) assert (trait_instance_id_is_local_clause trait_ref.trait_id); - T.TTraitType (trait_ref, generics, type_name) + TTraitType (trait_ref, generics, type_name) in - let tr : C.trait_type_ref = { C.trait_ref; type_name } in + let tr : trait_type_ref = { trait_ref; type_name } in (* Lookup the representative, if there is *) match norm_ctx_get_ty_repr ctx tr with None -> ty | Some ty -> ty) @@ -363,7 +335,7 @@ let rec norm_ctx_normalize_ty (ctx : norm_ctx) (ty : T.ty) : T.ty = over it. *) and norm_ctx_normalize_trait_instance_id (ctx : norm_ctx) - (id : T.trait_instance_id) : T.trait_instance_id * T.trait_ref option = + (id : trait_instance_id) : trait_instance_id * trait_ref option = match id with | Self -> (id, None) | TraitImpl _ -> @@ -435,7 +407,7 @@ and norm_ctx_normalize_trait_instance_id (ctx : norm_ctx) (* Normalize the clause *) let clause = norm_ctx_normalize_trait_ref ctx clause in (TraitRef clause, Some clause)) - | TraitRef { T.trait_id = T.TraitImpl trait_id; generics; trait_decl_ref } -> + | TraitRef { trait_id = TraitImpl trait_id; generics; trait_decl_ref } -> (* We can't simplify the id *yet* : we will simplify it when projecting. However, we have an implementation to return *) (* Normalize the generics *) @@ -443,15 +415,15 @@ and norm_ctx_normalize_trait_instance_id (ctx : norm_ctx) let trait_decl_ref = norm_ctx_normalize_trait_decl_ref ctx trait_decl_ref in - let trait_ref : T.trait_ref = - { T.trait_id = T.TraitImpl trait_id; generics; trait_decl_ref } + let trait_ref : trait_ref = + { trait_id = TraitImpl trait_id; generics; trait_decl_ref } in (TraitRef trait_ref, Some trait_ref) | TraitRef trait_ref -> (* The trait instance id necessarily refers to a local sub-clause. We can't project over it and can only peel off the [TraitRef] wrapper *) assert (trait_instance_id_is_local_clause trait_ref.trait_id); - assert (trait_ref.generics = TypesUtils.mk_empty_generic_args); + assert (trait_ref.generics = empty_generic_args); (trait_ref.trait_id, None) | FnPointer ty -> let ty = norm_ctx_normalize_ty ctx ty in @@ -462,21 +434,21 @@ and norm_ctx_normalize_trait_instance_id (ctx : norm_ctx) (* This is actually an error case *) (id, None) -and norm_ctx_normalize_generic_args (ctx : norm_ctx) (generics : T.generic_args) - : T.generic_args = - let { T.regions; types; const_generics; trait_refs } = generics in +and norm_ctx_normalize_generic_args (ctx : norm_ctx) (generics : generic_args) : + generic_args = + let { regions; types; const_generics; trait_refs } = generics in let types = List.map (norm_ctx_normalize_ty ctx) types in let trait_refs = List.map (norm_ctx_normalize_trait_ref ctx) trait_refs in - { T.regions; types; const_generics; trait_refs } + { regions; types; const_generics; trait_refs } -and norm_ctx_normalize_trait_ref (ctx : norm_ctx) (trait_ref : T.trait_ref) : - T.trait_ref = +and norm_ctx_normalize_trait_ref (ctx : norm_ctx) (trait_ref : trait_ref) : + trait_ref = log#ldebug (lazy ("norm_ctx_normalize_trait_ref: " ^ trait_ref_to_string ctx trait_ref - ^ "\n- raw trait ref:\n" ^ T.show_trait_ref trait_ref)); - let { T.trait_id; generics; trait_decl_ref } = trait_ref in + ^ "\n- raw trait ref:\n" ^ show_trait_ref trait_ref)); + let { trait_id; generics; trait_decl_ref } = trait_ref in (* Check if the id is an impl, otherwise normalize it *) let trait_id, norm_trait_ref = norm_ctx_normalize_trait_instance_id ctx trait_id @@ -491,31 +463,31 @@ and norm_ctx_normalize_trait_ref (ctx : norm_ctx) (trait_ref : T.trait_ref) : let trait_decl_ref = norm_ctx_normalize_trait_decl_ref ctx trait_decl_ref in - { T.trait_id; generics; trait_decl_ref } + { trait_id; generics; trait_decl_ref } | Some trait_ref -> log#ldebug (lazy ("norm_ctx_normalize_trait_ref: normalized to: " ^ trait_ref_to_string ctx trait_ref)); - assert (generics = TypesUtils.mk_empty_generic_args); + assert (generics = empty_generic_args); trait_ref (* Not sure this one is really necessary *) and norm_ctx_normalize_trait_decl_ref (ctx : norm_ctx) - (trait_decl_ref : T.trait_decl_ref) : T.trait_decl_ref = - let { T.trait_decl_id; decl_generics } = trait_decl_ref in + (trait_decl_ref : trait_decl_ref) : trait_decl_ref = + let { trait_decl_id; decl_generics } = trait_decl_ref in let decl_generics = norm_ctx_normalize_generic_args ctx decl_generics in - { T.trait_decl_id; decl_generics } + { trait_decl_id; decl_generics } let norm_ctx_normalize_trait_type_constraint (ctx : norm_ctx) - (ttc : T.trait_type_constraint) : T.trait_type_constraint = - let { T.trait_ref; generics; type_name; ty } = ttc in + (ttc : trait_type_constraint) : trait_type_constraint = + let { trait_ref; generics; type_name; ty } = ttc in let trait_ref = norm_ctx_normalize_trait_ref ctx trait_ref in let generics = norm_ctx_normalize_generic_args ctx generics in let ty = norm_ctx_normalize_ty ctx ty in - { T.trait_ref; generics; type_name; ty } + { trait_ref; generics; type_name; ty } -let mk_norm_ctx (ctx : C.eval_ctx) : norm_ctx = +let mk_norm_ctx (ctx : eval_ctx) : norm_ctx = { norm_trait_types = ctx.norm_trait_types; type_decls = ctx.type_context.type_decls; @@ -527,22 +499,22 @@ let mk_norm_ctx (ctx : C.eval_ctx) : norm_ctx = const_generic_vars = ctx.const_generic_vars; } -let ctx_normalize_ty (ctx : C.eval_ctx) (ty : T.ty) : T.ty = +let ctx_normalize_ty (ctx : eval_ctx) (ty : ty) : ty = norm_ctx_normalize_ty (mk_norm_ctx ctx) ty (** Normalize a type and erase the regions at the same time *) -let ctx_normalize_erase_ty (ctx : C.eval_ctx) (ty : T.ty) : T.ty = +let ctx_normalize_erase_ty (ctx : eval_ctx) (ty : ty) : ty = let ty = ctx_normalize_ty ctx ty in Subst.erase_regions ty -let ctx_normalize_trait_type_constraint (ctx : C.eval_ctx) - (ttc : T.trait_type_constraint) : T.trait_type_constraint = +let ctx_normalize_trait_type_constraint (ctx : eval_ctx) + (ttc : trait_type_constraint) : trait_type_constraint = norm_ctx_normalize_trait_type_constraint (mk_norm_ctx ctx) ttc (** Same as [type_decl_get_instantiated_variants_fields_types] but normalizes the types *) -let type_decl_get_inst_norm_variants_fields_rtypes (ctx : C.eval_ctx) - (def : T.type_decl) (generics : T.generic_args) : - (T.VariantId.id option * T.ty list) list = +let type_decl_get_inst_norm_variants_fields_rtypes (ctx : eval_ctx) + (def : type_decl) (generics : generic_args) : + (VariantId.id option * ty list) list = let res = Subst.type_decl_get_instantiated_variants_fields_types def generics in @@ -552,18 +524,16 @@ let type_decl_get_inst_norm_variants_fields_rtypes (ctx : C.eval_ctx) res (** Same as [type_decl_get_instantiated_field_types] but normalizes the types *) -let type_decl_get_inst_norm_field_rtypes (ctx : C.eval_ctx) (def : T.type_decl) - (opt_variant_id : T.VariantId.id option) (generics : T.generic_args) : - T.ty list = +let type_decl_get_inst_norm_field_rtypes (ctx : eval_ctx) (def : type_decl) + (opt_variant_id : VariantId.id option) (generics : generic_args) : ty list = let types = Subst.type_decl_get_instantiated_field_types def opt_variant_id generics in List.map (ctx_normalize_ty ctx) types (** Same as [ctx_adt_value_get_instantiated_field_rtypes] but normalizes the types *) -let ctx_adt_value_get_inst_norm_field_rtypes (ctx : C.eval_ctx) - (adt : V.adt_value) (id : T.type_id) (generics : T.generic_args) : T.ty list - = +let ctx_adt_value_get_inst_norm_field_rtypes (ctx : eval_ctx) (adt : adt_value) + (id : type_id) (generics : generic_args) : ty list = let types = Subst.ctx_adt_value_get_instantiated_field_types ctx adt id generics in @@ -571,9 +541,8 @@ let ctx_adt_value_get_inst_norm_field_rtypes (ctx : C.eval_ctx) (** Same as [ctx_adt_value_get_instantiated_field_types] but normalizes the types and erases the regions. *) -let type_decl_get_inst_norm_field_etypes (ctx : C.eval_ctx) (def : T.type_decl) - (opt_variant_id : T.VariantId.id option) (generics : T.generic_args) : - T.ty list = +let type_decl_get_inst_norm_field_etypes (ctx : eval_ctx) (def : type_decl) + (opt_variant_id : VariantId.id option) (generics : generic_args) : ty list = let types = Subst.type_decl_get_instantiated_field_types def opt_variant_id generics in @@ -582,9 +551,8 @@ let type_decl_get_inst_norm_field_etypes (ctx : C.eval_ctx) (def : T.type_decl) (** Same as [ctx_adt_get_instantiated_field_types] but normalizes the types and erases the regions. *) -let ctx_adt_get_inst_norm_field_etypes (ctx : C.eval_ctx) - (def_id : T.TypeDeclId.id) (opt_variant_id : T.VariantId.id option) - (generics : T.generic_args) : T.ty list = +let ctx_adt_get_inst_norm_field_etypes (ctx : eval_ctx) (def_id : TypeDeclId.id) + (opt_variant_id : VariantId.id option) (generics : generic_args) : ty list = let types = Subst.ctx_adt_get_instantiated_field_types ctx def_id opt_variant_id generics @@ -593,19 +561,18 @@ let ctx_adt_get_inst_norm_field_etypes (ctx : C.eval_ctx) List.map Subst.erase_regions types (** Same as [substitute_signature] but normalizes the types *) -let ctx_subst_norm_signature (ctx : C.eval_ctx) - (asubst : T.RegionGroupId.id -> V.AbstractionId.id) - (r_subst : T.RegionId.id -> T.RegionId.id) - (ty_subst : T.TypeVarId.id -> T.ty) - (cg_subst : T.ConstGenericVarId.id -> T.const_generic) - (tr_subst : T.TraitClauseId.id -> T.trait_instance_id) - (tr_self : T.trait_instance_id) (sg : A.fun_sig) - (regions_hierarchy : T.region_groups) : A.inst_fun_sig = +let ctx_subst_norm_signature (ctx : eval_ctx) + (asubst : RegionGroupId.id -> AbstractionId.id) + (r_subst : RegionId.id -> RegionId.id) (ty_subst : TypeVarId.id -> ty) + (cg_subst : ConstGenericVarId.id -> const_generic) + (tr_subst : TraitClauseId.id -> trait_instance_id) + (tr_self : trait_instance_id) (sg : fun_sig) + (regions_hierarchy : region_groups) : inst_fun_sig = let sg = Subst.substitute_signature asubst r_subst ty_subst cg_subst tr_subst tr_self sg regions_hierarchy in - let { A.regions_hierarchy; inputs; output; trait_type_constraints } = sg in + let { regions_hierarchy; inputs; output; trait_type_constraints } = sg in let inputs = List.map (ctx_normalize_ty ctx) inputs in let output = ctx_normalize_ty ctx output in let trait_type_constraints = diff --git a/compiler/Assumed.ml b/compiler/Assumed.ml index aa0cfccf..6aec626a 100644 --- a/compiler/Assumed.ml +++ b/compiler/Assumed.ml @@ -29,58 +29,57 @@ ]} *) -open Names +open Types open TypesUtils -module T = Types -module A = LlbcAst +open LlbcAst module Sig = struct (** A few utilities *) - let rvar_id_0 = T.RegionId.of_int 0 - let rvar_0 : T.region = T.RVar 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.ty = T.TVar tvar_id_0 - let cgvar_id_0 = T.ConstGenericVarId.of_int 0 - let cgvar_0 : T.const_generic = T.CGVar cgvar_id_0 + let rvar_id_0 = RegionId.of_int 0 + let rvar_0 : region = RVar rvar_id_0 + let rg_id_0 = RegionGroupId.of_int 0 + let tvar_id_0 = TypeVarId.of_int 0 + let tvar_0 : ty = TVar tvar_id_0 + let cgvar_id_0 = ConstGenericVarId.of_int 0 + let cgvar_0 : const_generic = CGVar cgvar_id_0 (** Region 'a of id 0 *) - let region_param_0 : T.region_var = { T.index = rvar_id_0; name = Some "'a" } + let region_param_0 : region_var = { index = rvar_id_0; name = Some "'a" } (** Region group: [{ parent={}; regions:{'a of id 0} }] *) - let region_group_0 : T.region_group = - { T.id = rg_id_0; regions = [ rvar_id_0 ]; parents = [] } + let region_group_0 : region_group = + { 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 type_param_0 : type_var = { index = tvar_id_0; name = "T" } - let usize_ty : T.ty = T.TLiteral (TInteger Usize) + let usize_ty : ty = TLiteral (TInteger Usize) (** Const generic parameter [const N : usize] of id 0 *) - let cg_param_0 : T.const_generic_var = - { T.index = cgvar_id_0; name = "N"; ty = TInteger Usize } + let cg_param_0 : const_generic_var = + { index = cgvar_id_0; name = "N"; ty = TInteger Usize } - let empty_const_generic_params : T.const_generic_var list = [] + let empty_const_generic_params : const_generic_var list = [] - let mk_generic_args regions types const_generics : T.generic_args = + let mk_generic_args regions types const_generics : generic_args = { regions; types; const_generics; trait_refs = [] } - let mk_generic_params regions types const_generics : T.generic_params = + let mk_generic_params regions types const_generics : generic_params = { regions; types; const_generics; trait_clauses = [] } - let mk_ref_ty (r : T.region) (ty : T.ty) (is_mut : bool) : T.ty = - let ref_kind = if is_mut then T.Mut else T.Shared in + let mk_ref_ty (r : region) (ty : ty) (is_mut : bool) : ty = + let ref_kind = if is_mut then RMut else RShared in mk_ref_ty r ty ref_kind - let mk_array_ty (ty : T.ty) (cg : T.const_generic) : T.ty = + let mk_array_ty (ty : ty) (cg : const_generic) : ty = TAdt (TAssumed TArray, mk_generic_args [] [ ty ] [ cg ]) - let mk_slice_ty (ty : T.ty) : T.ty = + let mk_slice_ty (ty : ty) : ty = TAdt (TAssumed TSlice, mk_generic_args [] [ ty ] []) - let mk_sig generics inputs output : A.fun_sig = - let preds : T.predicates = + let mk_sig generics inputs output : fun_sig = + let preds : predicates = { regions_outlive = []; types_outlive = []; trait_type_constraints = [] } in { @@ -93,14 +92,14 @@ module Sig = struct } (** [fn<T>(T) -> Box<T>] *) - let box_new_sig : A.fun_sig = + let box_new_sig : fun_sig = let generics = mk_generic_params [] [ type_param_0 ] [] (* <T> *) in let inputs = [ tvar_0 (* T *) ] in let output = mk_box_ty tvar_0 (* Box<T> *) in mk_sig generics inputs output (** [fn<T>(Box<T>) -> ()] *) - let box_free_sig : A.fun_sig = + let box_free_sig : fun_sig = let generics = mk_generic_params [] [ type_param_0 ] [] (* <T> *) in let inputs = [ mk_box_ty tvar_0 (* Box<T> *) ] in let output = mk_unit_ty (* () *) in @@ -120,9 +119,9 @@ module Sig = struct The [mut_borrow] boolean controls whether we use a shared or a mutable borrow. *) - let mk_array_slice_borrow_sig (cgs : T.const_generic_var list) - (input_ty : T.TypeVarId.id -> T.ty) (index_ty : T.ty option) - (output_ty : T.TypeVarId.id -> T.ty) (is_mut : bool) : A.fun_sig = + let mk_array_slice_borrow_sig (cgs : const_generic_var list) + (input_ty : TypeVarId.id -> ty) (index_ty : ty option) + (output_ty : TypeVarId.id -> ty) (is_mut : bool) : fun_sig = let generics = mk_generic_params [ region_param_0 ] [ type_param_0 ] cgs (* <'a, T> *) in @@ -143,27 +142,26 @@ module Sig = struct in mk_sig generics inputs output - let mk_array_slice_index_sig (is_array : bool) (is_mut : bool) : A.fun_sig = + let mk_array_slice_index_sig (is_array : bool) (is_mut : bool) : fun_sig = (* Array<T, N> *) let input_ty id = - if is_array then mk_array_ty (T.TVar id) cgvar_0 - else mk_slice_ty (T.TVar id) + if is_array then mk_array_ty (TVar id) cgvar_0 else mk_slice_ty (TVar id) in (* usize *) let index_ty = usize_ty in (* T *) - let output_ty id = T.TVar id in + let output_ty id = TVar id in let cgs = if is_array then [ cg_param_0 ] else [] in mk_array_slice_borrow_sig cgs input_ty (Some index_ty) output_ty is_mut let array_index_sig (is_mut : bool) = mk_array_slice_index_sig true is_mut let slice_index_sig (is_mut : bool) = mk_array_slice_index_sig false is_mut - let array_to_slice_sig (is_mut : bool) : A.fun_sig = + let array_to_slice_sig (is_mut : bool) : fun_sig = (* Array<T, N> *) - let input_ty id = mk_array_ty (T.TVar id) cgvar_0 in + let input_ty id = mk_array_ty (TVar id) cgvar_0 in (* Slice<T> *) - let output_ty id = mk_slice_ty (T.TVar id) in + let output_ty id = mk_slice_ty (TVar id) in let cgs = [ cg_param_0 ] in mk_array_slice_borrow_sig cgs input_ty None output_ty is_mut @@ -182,7 +180,7 @@ module Sig = struct (** Helper: [fn<T>(&'a [T]) -> usize] *) - let slice_len_sig : A.fun_sig = + let slice_len_sig : fun_sig = let generics = mk_generic_params [ region_param_0 ] [ type_param_0 ] [] (* <'a, T> *) in @@ -194,13 +192,13 @@ module Sig = struct end type raw_assumed_fun_info = - A.assumed_fun_id * A.fun_sig * bool * name * bool list option + assumed_fun_id * fun_sig * bool * string * bool list option type assumed_fun_info = { - fun_id : A.assumed_fun_id; - fun_sig : A.fun_sig; + fun_id : assumed_fun_id; + fun_sig : fun_sig; can_fail : bool; - name : name; + name : string; keep_types : bool list option; (** We may want to filter some type arguments. @@ -226,70 +224,63 @@ let mk_assumed_fun_info (raw : raw_assumed_fun_info) : assumed_fun_info = *) let raw_assumed_fun_infos : raw_assumed_fun_info list = [ + (* TODO: the names are not correct ("Box" should be an impl elem for instance) + but it's not important) *) ( BoxNew, Sig.box_new_sig, false, - to_name [ "alloc"; "boxed"; "Box"; "new" ], + "alloc::boxed::Box::new", Some [ true; false ] ); (* BoxFree shouldn't be used *) ( BoxFree, Sig.box_free_sig, false, - to_name [ "alloc"; "boxed"; "Box"; "free" ], + "alloc::boxed::Box::free", Some [ true; false ] ); (* Array Index *) ( ArrayIndexShared, Sig.array_index_sig false, true, - to_name [ "@ArrayIndexShared" ], - None ); - ( ArrayIndexMut, - Sig.array_index_sig true, - true, - to_name [ "@ArrayIndexMut" ], + "@ArrayIndexShared", None ); + (ArrayIndexMut, Sig.array_index_sig true, true, "@ArrayIndexMut", None); (* Array to slice*) ( ArrayToSliceShared, Sig.array_to_slice_sig false, true, - to_name [ "@ArrayToSliceShared" ], + "@ArrayToSliceShared", None ); ( ArrayToSliceMut, Sig.array_to_slice_sig true, true, - to_name [ "@ArrayToSliceMut" ], + "@ArrayToSliceMut", None ); (* Array Repeat *) - (ArrayRepeat, Sig.array_repeat_sig, false, to_name [ "@ArrayRepeat" ], None); + (ArrayRepeat, Sig.array_repeat_sig, false, "@ArrayRepeat", None); (* Slice Index *) ( SliceIndexShared, Sig.slice_index_sig false, true, - to_name [ "@SliceIndexShared" ], - None ); - ( SliceIndexMut, - Sig.slice_index_sig true, - true, - to_name [ "@SliceIndexMut" ], + "@SliceIndexShared", None ); - (SliceLen, Sig.slice_len_sig, false, to_name [ "@SliceLen" ], None); + (SliceIndexMut, Sig.slice_index_sig true, true, "@SliceIndexMut", None); ] let assumed_fun_infos : assumed_fun_info list = List.map mk_assumed_fun_info raw_assumed_fun_infos -let get_assumed_fun_info (id : A.assumed_fun_id) : assumed_fun_info = +let get_assumed_fun_info (id : assumed_fun_id) : assumed_fun_info = match List.find_opt (fun x -> id = x.fun_id) assumed_fun_infos with | Some info -> info | None -> raise - (Failure ("get_assumed_fun_info: not found: " ^ A.show_assumed_fun_id id)) + (Failure ("get_assumed_fun_info: not found: " ^ show_assumed_fun_id id)) -let get_assumed_fun_sig (id : A.assumed_fun_id) : A.fun_sig = +let get_assumed_fun_sig (id : assumed_fun_id) : fun_sig = (get_assumed_fun_info id).fun_sig -let get_assumed_fun_name (id : A.assumed_fun_id) : fun_name = +let get_assumed_fun_name (id : assumed_fun_id) : string = (get_assumed_fun_info id).name -let assumed_fun_can_fail (id : A.assumed_fun_id) : bool = +let assumed_fun_can_fail (id : assumed_fun_id) : bool = (get_assumed_fun_info id).can_fail diff --git a/compiler/Contexts.ml b/compiler/Contexts.ml index 17ebd315..41c84141 100644 --- a/compiler/Contexts.ml +++ b/compiler/Contexts.ml @@ -3,7 +3,6 @@ open Expressions open Values open LlbcAst open LlbcAstUtils -module V = Values open ValuesUtils open Identifiers module L = Logging @@ -191,7 +190,7 @@ type type_context = { type fun_context = { fun_decls : fun_decl FunDeclId.Map.t; fun_infos : FunsAnalysis.fun_info FunDeclId.Map.t; - regions_hierarchies : T.region_groups FunIdMap.t; + regions_hierarchies : region_groups FunIdMap.t; } [@@deriving show] @@ -371,7 +370,7 @@ let ctx_push_vars (ctx : eval_ctx) (vars : (var * typed_value) list) : eval_ctx (List.map (fun (var, value) -> (* We can unfortunately not use Print because it depends on Contexts... *) - show_var var ^ " -> " ^ V.show_typed_value value) + show_var var ^ " -> " ^ show_typed_value value) vars))); assert ( List.for_all @@ -433,7 +432,7 @@ let ctx_push_uninitialized_vars (ctx : eval_ctx) (vars : var list) : eval_ctx = let vars = List.map (fun v -> (v, mk_bottom (erase_regions v.var_ty))) vars in ctx_push_vars ctx vars -let env_find_abs (env : env) (pred : V.abs -> bool) : V.abs option = +let env_find_abs (env : env) (pred : abs -> bool) : abs option = let rec lookup env = match env with | [] -> None @@ -443,16 +442,15 @@ let env_find_abs (env : env) (pred : V.abs -> bool) : V.abs option = in lookup env -let env_lookup_abs (env : env) (abs_id : V.AbstractionId.id) : V.abs = +let env_lookup_abs (env : env) (abs_id : AbstractionId.id) : abs = Option.get (env_find_abs env (fun abs -> abs.abs_id = abs_id)) (** Remove an abstraction from the context, as well as all the references to this abstraction (for instance, remove the abs id from all the parent sets of all the other abstractions). *) -let env_remove_abs (env : env) (abs_id : V.AbstractionId.id) : - env * V.abs option = - let rec remove (env : env) : env * V.abs option = +let env_remove_abs (env : env) (abs_id : AbstractionId.id) : env * abs option = + let rec remove (env : env) : env * abs option = match env with | [] -> raise (Failure "Unreachable") | EFrame :: _ -> (env, None) @@ -464,8 +462,8 @@ let env_remove_abs (env : env) (abs_id : V.AbstractionId.id) : else let env, abs_opt = remove env in (* Update the parents set *) - let parents = V.AbstractionId.Set.remove abs_id abs.parents in - (EAbs { abs with V.parents } :: env, abs_opt) + let parents = AbstractionId.Set.remove abs_id abs.parents in + (EAbs { abs with parents } :: env, abs_opt) in remove env @@ -476,9 +474,9 @@ let env_remove_abs (env : env) (abs_id : V.AbstractionId.id) : we also substitute the abstraction id wherever it is used (i.e., in the parent sets of the other abstractions). *) -let env_subst_abs (env : env) (abs_id : V.AbstractionId.id) (nabs : V.abs) : - env * V.abs option = - let rec update (env : env) : env * V.abs option = +let env_subst_abs (env : env) (abs_id : AbstractionId.id) (nabs : abs) : + env * abs option = + let rec update (env : env) : env * abs option = match env with | [] -> raise (Failure "Unreachable") | EFrame :: _ -> (* We're done *) (env, None) @@ -492,34 +490,34 @@ let env_subst_abs (env : env) (abs_id : V.AbstractionId.id) (nabs : V.abs) : (* Update the parents set *) let parents = abs.parents in let parents = - if V.AbstractionId.Set.mem abs_id parents then - let parents = V.AbstractionId.Set.remove abs_id parents in - V.AbstractionId.Set.add nabs.abs_id parents + if AbstractionId.Set.mem abs_id parents then + let parents = AbstractionId.Set.remove abs_id parents in + AbstractionId.Set.add nabs.abs_id parents else parents in - (EAbs { abs with V.parents } :: env, opt_abs) + (EAbs { abs with parents } :: env, opt_abs) in update env -let ctx_lookup_abs (ctx : eval_ctx) (abs_id : V.AbstractionId.id) : V.abs = +let ctx_lookup_abs (ctx : eval_ctx) (abs_id : AbstractionId.id) : abs = env_lookup_abs ctx.env abs_id -let ctx_find_abs (ctx : eval_ctx) (p : V.abs -> bool) : V.abs option = +let ctx_find_abs (ctx : eval_ctx) (p : abs -> bool) : abs option = env_find_abs ctx.env p (** See the comments for {!env_remove_abs} *) -let ctx_remove_abs (ctx : eval_ctx) (abs_id : V.AbstractionId.id) : - eval_ctx * V.abs option = +let ctx_remove_abs (ctx : eval_ctx) (abs_id : AbstractionId.id) : + eval_ctx * abs option = let env, abs = env_remove_abs ctx.env abs_id in ({ ctx with env }, abs) (** See the comments for {!env_subst_abs} *) -let ctx_subst_abs (ctx : eval_ctx) (abs_id : V.AbstractionId.id) (nabs : V.abs) - : eval_ctx * V.abs option = +let ctx_subst_abs (ctx : eval_ctx) (abs_id : AbstractionId.id) (nabs : abs) : + eval_ctx * abs option = let env, abs_opt = env_subst_abs ctx.env abs_id nabs in ({ ctx with env }, abs_opt) -let ctx_set_abs_can_end (ctx : eval_ctx) (abs_id : V.AbstractionId.id) +let ctx_set_abs_can_end (ctx : eval_ctx) (abs_id : AbstractionId.id) (can_end : bool) : eval_ctx = let abs = ctx_lookup_abs ctx abs_id in let abs = { abs with can_end } in @@ -580,19 +578,19 @@ class ['self] map_eval_ctx = { ctx with env } end -let env_iter_abs (f : V.abs -> unit) (env : env) : unit = +let env_iter_abs (f : abs -> unit) (env : env) : unit = List.iter (fun (ee : env_elem) -> match ee with EBinding _ | EFrame -> () | EAbs abs -> f abs) env -let env_map_abs (f : V.abs -> V.abs) (env : env) : env = +let env_map_abs (f : abs -> abs) (env : env) : env = List.map (fun (ee : env_elem) -> match ee with EBinding _ | EFrame -> ee | EAbs abs -> EAbs (f abs)) env -let env_filter_abs (f : V.abs -> bool) (env : env) : env = +let env_filter_abs (f : abs -> bool) (env : env) : env = List.filter (fun (ee : env_elem) -> match ee with EBinding _ | EFrame -> true | EAbs abs -> f abs) diff --git a/compiler/Cps.ml b/compiler/Cps.ml index c0dd0ae2..a3c8f1e1 100644 --- a/compiler/Cps.ml +++ b/compiler/Cps.ml @@ -1,10 +1,8 @@ (** 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 +open Values +open Contexts (** TODO: change the name *) type eval_error = EPanic @@ -16,9 +14,9 @@ type statement_eval_res = | Continue of int | Return | Panic - | LoopReturn of V.loop_id + | LoopReturn of loop_id (** We reached a return statement *while inside a loop* *) - | EndEnterLoop of V.loop_id * V.typed_value V.SymbolicValueId.Map.t + | EndEnterLoop of loop_id * typed_value SymbolicValueId.Map.t (** When we enter a loop, we delegate the end of the function is synthesized with a call to the loop translation. We use this evaluation result to transmit the fact that we end evaluation @@ -27,7 +25,7 @@ type statement_eval_res = We provide the list of values for the translated loop function call (or to be more precise the input values instantiation). *) - | EndContinue of V.loop_id * V.typed_value V.SymbolicValueId.Map.t + | EndContinue of loop_id * typed_value SymbolicValueId.Map.t (** For loop translations: we end with a continue (i.e., a recursive call to the translation for the loop body). @@ -36,21 +34,21 @@ type statement_eval_res = *) [@@deriving show] -type eval_result = SA.expression option +type eval_result = SymbolicAst.expression option (** Continuation function *) -type m_fun = C.eval_ctx -> eval_result +type m_fun = 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 +type typed_value_m_fun = 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 typed_value_cm_fun = typed_value -> cm_fun (** Type of a continuation used when evaluating a statement *) type st_m_fun = statement_eval_res -> m_fun @@ -59,13 +57,13 @@ type st_m_fun = statement_eval_res -> m_fun 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 = +let unit_to_cm_fun (f : 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 = +let update_to_cm_fun (f : eval_ctx -> eval_ctx) : cm_fun = fun cf ctx -> let ctx = f ctx in cf ctx @@ -75,10 +73,10 @@ let update_to_cm_fun (f : C.eval_ctx -> C.eval_ctx) : cm_fun = 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 = +let comp_unit (f : cm_fun) (g : 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 = +let comp_update (f : cm_fun) (g : eval_ctx -> 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 @@ -88,8 +86,8 @@ let comp_update (f : cm_fun) (g : C.eval_ctx -> C.eval_ctx) : cm_fun = 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 = +let comp_ret_val (f : (typed_value -> m_fun) -> m_fun) + (g : m_fun -> typed_value -> m_fun) : cm_fun = comp f g let apply (f : cm_fun) (g : m_fun) : m_fun = fun ctx -> f g ctx diff --git a/compiler/ExtractBase.ml b/compiler/ExtractBase.ml index 4ce1e9f1..ae5a9a22 100644 --- a/compiler/ExtractBase.ml +++ b/compiler/ExtractBase.ml @@ -1,14 +1,13 @@ (** Define base utilities for the extraction *) +open Contexts open Pure open TranslateCore -module C = Contexts -module RegionId = T.RegionId module F = Format open ExtractBuiltin (** The local logger *) -let log = L.extract_log +let log = Logging.extract_log type region_group_info = { id : RegionGroupId.id; @@ -25,11 +24,6 @@ type region_group_info = { module StringSet = Collections.StringSet module StringMap = Collections.StringMap -type name = Names.name -type type_name = Names.type_name -type global_name = Names.global_name -type fun_name = Names.fun_name - (** Characterizes a declaration. Is in particular useful to derive the proper keywords to introduce the @@ -151,7 +145,7 @@ type formatter = { Remark: can return [None] for some backends like HOL4. *) - field_name : name -> FieldId.id -> string option -> string; + field_name : llbc_name -> FieldId.id -> string option -> string; (** Inputs: - type name - field id @@ -163,12 +157,12 @@ type formatter = { access then causes trouble because not all provers accept syntax like [x.3] where [x] is a tuple. *) - variant_name : name -> string -> string; + variant_name : llbc_name -> string -> string; (** Inputs: - type name - variant name *) - struct_constructor : name -> string; + struct_constructor : llbc_name -> string; (** Structure constructors are used when constructing structure values. For instance, in F*: @@ -179,13 +173,13 @@ type formatter = { Inputs: - type name - *) - type_name : type_name -> string; + *) + type_name : llbc_name -> string; (** Provided a basename, compute a type name. *) - global_name : global_name -> string; + global_name : llbc_name -> string; (** Provided a basename, compute a global name. *) fun_name : - fun_name -> + llbc_name -> int -> LoopId.id option -> int -> @@ -213,7 +207,7 @@ type formatter = { TODO: use the fun id for the assumed functions. *) termination_measure_name : - A.FunDeclId.id -> fun_name -> int -> LoopId.id option -> string; + A.FunDeclId.id -> llbc_name -> int -> LoopId.id option -> string; (** Generates the name of the termination measure used to prove/reason about termination. The generated code uses this clause where needed, but its body must be defined by the user. @@ -225,11 +219,11 @@ type formatter = { function is an assumed function or a local function - function basename - the number of loops in the parent function. This is used for - the same purpose as in {!field:fun_name}. + the same purpose as in {!field:llbc_name}. - loop identifier, if this is for a loop *) decreases_proof_name : - A.FunDeclId.id -> fun_name -> int -> LoopId.id option -> string; + A.FunDeclId.id -> llbc_name -> int -> LoopId.id option -> string; (** Generates the name of the proof used to prove/reason about termination. The generated code uses this clause where needed, but its body must be defined by the user. @@ -241,7 +235,7 @@ type formatter = { function is an assumed function or a local function - function basename - the number of loops in the parent function. This is used for - the same purpose as in {!field:fun_name}. + the same purpose as in {!field:llbc_name}. - loop identifier, if this is for a loop *) trait_decl_name : trait_decl -> string; @@ -654,72 +648,47 @@ type extraction_ctx = { (** Same as {!types_filter_type_args_map}, but for trait implementations *) } +let extraction_ctx_to_fmt_env (ctx : extraction_ctx) : PrintPure.fmt_env = + TranslateCore.trans_ctx_to_pure_fmt_env ctx.trans_ctx + +let name_to_string (ctx : extraction_ctx) = + PrintPure.name_to_string (extraction_ctx_to_fmt_env ctx) + +let trait_decl_id_to_string (ctx : extraction_ctx) = + PrintPure.trait_decl_id_to_string (extraction_ctx_to_fmt_env ctx) + +let type_id_to_string (ctx : extraction_ctx) = + PrintPure.type_id_to_string (extraction_ctx_to_fmt_env ctx) + +let global_decl_id_to_string (ctx : extraction_ctx) = + PrintPure.global_decl_id_to_string (extraction_ctx_to_fmt_env ctx) + +let llbc_fun_id_to_string (ctx : extraction_ctx) = + PrintPure.llbc_fun_id_to_string (extraction_ctx_to_fmt_env ctx) + +let fun_id_to_string (ctx : extraction_ctx) = + PrintPure.regular_fun_id_to_string (extraction_ctx_to_fmt_env ctx) + +let adt_variant_to_string (ctx : extraction_ctx) = + PrintPure.adt_variant_to_string (extraction_ctx_to_fmt_env ctx) + +let adt_field_to_string (ctx : extraction_ctx) = + PrintPure.adt_field_to_string (extraction_ctx_to_fmt_env ctx) + (** Debugging function, used when communicating name collisions to the user, and also to print ids for internal debugging (in case of lookup miss for instance). *) let id_to_string (id : id) (ctx : extraction_ctx) : string = - let global_decls = ctx.trans_ctx.global_ctx.global_decls in - let fun_decls = ctx.trans_ctx.fun_ctx.fun_decls in - let type_decls = ctx.trans_ctx.type_ctx.type_decls in - let trait_decls = ctx.trans_ctx.trait_decls_ctx.trait_decls in let trait_decl_id_to_string (id : A.TraitDeclId.id) : string = - let trait_name = - Print.fun_name_to_string (A.TraitDeclId.Map.find id trait_decls).name - in + let trait_name = trait_decl_id_to_string ctx id in "trait_decl: " ^ trait_name ^ " (id: " ^ A.TraitDeclId.to_string id ^ ")" in - (* TODO: factorize the pretty-printing with what is in PrintPure *) - let get_type_name (id : type_id) : string = - match id with - | TAdtId id -> - let def = TypeDeclId.Map.find id type_decls in - Print.name_to_string def.name - | TAssumed aty -> show_assumed_ty aty - | TTuple -> raise (Failure "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 -> ( - match fid with - | FromLlbc (fid, lp_id, rg_id) -> - let fun_name = - match fid with - | FunId (FRegular fid) -> - Print.fun_name_to_string - (A.FunDeclId.Map.find fid fun_decls).name - | FunId (FAssumed aid) -> A.show_assumed_fun_id aid - | TraitMethod (trait_ref, method_name, _) -> - (* Shouldn't happen *) - if !Config.fail_hard then raise (Failure "Unexpected") - else - "Trait method: decl: " - ^ TraitDeclId.to_string trait_ref.trait_decl_ref.trait_decl_id - ^ ", method_name: " ^ method_name - in - - let lp_kind = - match lp_id with - | None -> "" - | Some lp_id -> "loop " ^ LoopId.to_string lp_id ^ ", " - in - - let fwd_back_kind = - match rg_id with - | None -> "forward" - | Some rg_id -> "backward " ^ RegionGroupId.to_string rg_id - in - "fun name (" ^ lp_kind ^ fwd_back_kind ^ "): " ^ fun_name - | Pure fid -> PrintPure.pure_assumed_fun_id_to_string fid) + | GlobalId gid -> global_decl_id_to_string ctx gid + | FunId fid -> fun_id_to_string ctx fid | DecreasesProofId (fid, lid) -> - let fun_name = - match fid with - | FRegular fid -> - Print.fun_name_to_string (A.FunDeclId.Map.find fid fun_decls).name - | FAssumed aid -> A.show_assumed_fun_id aid - in + let fun_name = llbc_fun_id_to_string ctx fid in let loop = match lid with | None -> "" @@ -727,73 +696,20 @@ let id_to_string (id : id) (ctx : extraction_ctx) : string = in "decreases proof for function: " ^ fun_name ^ loop | TerminationMeasureId (fid, lid) -> - let fun_name = - match fid with - | FRegular fid -> - Print.fun_name_to_string (A.FunDeclId.Map.find fid fun_decls).name - | FAssumed aid -> A.show_assumed_fun_id aid - in + let fun_name = llbc_fun_id_to_string ctx fid in let loop = match lid with | None -> "" | Some lid -> ", loop: " ^ LoopId.to_string lid in "termination measure for function: " ^ fun_name ^ loop - | TypeId id -> "type name: " ^ get_type_name id - | StructId id -> "struct constructor of: " ^ get_type_name id + | TypeId id -> "type name: " ^ type_id_to_string ctx id + | StructId id -> "struct constructor of: " ^ type_id_to_string ctx id | VariantId (id, variant_id) -> - let variant_name = - match id with - | TTuple -> raise (Failure "Unreachable") - | TAssumed TResult -> - if variant_id = result_return_id then "@result::Return" - else if variant_id = result_fail_id then "@result::Fail" - else raise (Failure "Unreachable") - | TAssumed TError -> - if variant_id = error_failure_id then "@error::Failure" - else if variant_id = error_out_of_fuel_id then "@error::OutOfFuel" - else raise (Failure "Unreachable") - | TAssumed TFuel -> - if variant_id = fuel_zero_id then "@fuel::0" - else if variant_id = fuel_succ_id then "@fuel::Succ" - else raise (Failure "Unreachable") - | TAssumed (TState | TArray | TSlice | TStr | TRawPtr _) -> - raise - (Failure - ("Unreachable: variant id (" - ^ VariantId.to_string variant_id - ^ ") for " ^ show_type_id id)) - | TAdtId id -> ( - let def = TypeDeclId.Map.find id type_decls in - match def.kind with - | Struct _ | Opaque -> raise (Failure "Unreachable") - | Enum variants -> - let variant = VariantId.nth variants variant_id in - Print.name_to_string def.name ^ "::" ^ variant.variant_name) - in + let variant_name = adt_variant_to_string ctx id (Some variant_id) in "variant name: " ^ variant_name | FieldId (id, field_id) -> - let field_name = - match id with - | TTuple -> raise (Failure "Unreachable") - | TAssumed - ( TState | TResult | TError | TFuel | TArray | TSlice | TStr - | TRawPtr _ ) -> - (* We can't directly have access to the fields of those types *) - raise (Failure "Unreachable") - | TAdtId id -> ( - let def = TypeDeclId.Map.find id type_decls in - match def.kind with - | Enum _ | Opaque -> raise (Failure "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 + let field_name = adt_field_to_string ctx id field_id in "field name: " ^ field_name | UnknownId -> "keyword" | TypeVarId id -> "type_var_id: " ^ TypeVarId.to_string id @@ -1148,7 +1064,7 @@ let ctx_add_generic_params (generics : generic_params) (ctx : extraction_ctx) : let ctx_add_decreases_proof (def : fun_decl) (ctx : extraction_ctx) : extraction_ctx = let name = - ctx.fmt.decreases_proof_name def.def_id def.basename def.num_loops + ctx.fmt.decreases_proof_name def.def_id def.llbc_name def.num_loops def.loop_id in ctx_add (DecreasesProofId (FRegular def.def_id, def.loop_id)) name ctx @@ -1156,7 +1072,7 @@ let ctx_add_decreases_proof (def : fun_decl) (ctx : extraction_ctx) : let ctx_add_termination_measure (def : fun_decl) (ctx : extraction_ctx) : extraction_ctx = let name = - ctx.fmt.termination_measure_name def.def_id def.basename def.num_loops + ctx.fmt.termination_measure_name def.def_id def.llbc_name def.num_loops def.loop_id in ctx_add (TerminationMeasureId (FRegular def.def_id, def.loop_id)) name ctx @@ -1177,7 +1093,7 @@ let ctx_add_global_decl_and_body (def : A.global_decl) (ctx : extraction_ctx) : | None -> (* Not the case: "standard" registration *) let name = ctx.fmt.global_name def.name in - let body = FunId (FromLlbc (FunId (FRegular def.body_id), None, None)) in + let body = FunId (FromLlbc (FunId (FRegular def.body), None, None)) in let ctx = ctx_add decl (name ^ "_c") ctx in let ctx = ctx_add body (name ^ "_body") ctx in ctx @@ -1208,7 +1124,7 @@ let ctx_compute_fun_name (trans_group : pure_fun_translation) (def : fun_decl) Some { id = rg_id; region_names } in (* Add the function name *) - ctx.fmt.fun_name def.basename def.num_loops def.loop_id num_rgs rg_info + ctx.fmt.fun_name def.llbc_name def.num_loops def.loop_id num_rgs rg_info (keep_fwd, num_backs) (* TODO: move to Extract *) @@ -1318,7 +1234,7 @@ let initialize_names_maps (fmt : formatter) (init : names_map_init) : names_maps nm let compute_type_decl_name (fmt : formatter) (def : type_decl) : string = - fmt.type_name def.name + fmt.type_name def.llbc_name (** Helper function: generate a suffix for a function name, i.e., generates a suffix like "_loop", "loop1", etc. to append to a function name. diff --git a/compiler/ExtractBuiltin.ml b/compiler/ExtractBuiltin.ml index a54ab604..db942ff0 100644 --- a/compiler/ExtractBuiltin.ml +++ b/compiler/ExtractBuiltin.ml @@ -4,14 +4,21 @@ TODO: there misses trait **implementations** *) -open Names open Config +open Types type simple_name = string list [@@deriving show, ord] +(* TODO: update *) let name_to_simple_name (s : name) : simple_name = - (* We simply ignore the disambiguators *) - List.filter_map (function Ident id -> Some id | Disambiguator _ -> None) s + (* We simply ignore the disambiguators - TODO: update *) + List.map + (function + | PeIdent (id, _) -> id + | PeImpl i -> + (* TODO *) + show_impl_elem i) + s (** Small helper which cuts a string at the occurrences of "::" *) let string_to_simple_name (s : string) : simple_name = diff --git a/compiler/FunsAnalysis.ml b/compiler/FunsAnalysis.ml index 1f17c1aa..d6898e96 100644 --- a/compiler/FunsAnalysis.ml +++ b/compiler/FunsAnalysis.ml @@ -175,15 +175,15 @@ let analyze_module (m : crate) (funs_map : fun_decl FunDeclId.Map.t) let rec analyze_decl_groups (decls : declaration_group list) : unit = match decls with | [] -> () - | (Type _ | TraitDecl _ | TraitImpl _) :: decls' -> + | (TypeGroup _ | TraitDeclGroup _ | TraitImplGroup _) :: decls' -> analyze_decl_groups decls' - | Fun decl :: decls' -> + | FunGroup decl :: decls' -> analyze_fun_decl_group decl; analyze_decl_groups decls' - | Global id :: decls' -> + | GlobalGroup 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_fun_decl_group (NonRec global.body); analyze_decl_groups decls' in diff --git a/compiler/Interpreter.ml b/compiler/Interpreter.ml index e9c0f17f..5b2db90d 100644 --- a/compiler/Interpreter.ml +++ b/compiler/Interpreter.ml @@ -4,19 +4,22 @@ open InterpreterProjectors open InterpreterBorrows open InterpreterStatements open LlbcAstUtils -module L = Logging -module T = Types -module A = LlbcAst +open Types +open TypesUtils +open Values +open LlbcAst +open Contexts +open SynthesizeSymbolic module SA = SymbolicAst (** The local logger *) -let log = L.interpreter_log +let log = Logging.interpreter_log -let compute_contexts (m : A.crate) : C.decls_ctx = +let compute_contexts (m : crate) : decls_ctx = let type_decls_list, _, _, _, _ = split_declarations m.declarations in - let type_decls = m.types in - let fun_decls = m.functions in - let global_decls = m.globals in + let type_decls = m.type_decls in + let fun_decls = m.fun_decls in + let global_decls = m.global_decls in let trait_decls = m.trait_decls in let trait_impls = m.trait_impls in let type_decls_groups, _, _, _, _ = @@ -25,7 +28,7 @@ let compute_contexts (m : A.crate) : C.decls_ctx = let type_infos = TypesAnalysis.analyze_type_declarations type_decls type_decls_list in - let type_ctx = { C.type_decls_groups; type_decls; type_infos } in + let type_ctx = { type_decls_groups; type_decls; type_infos } in let fun_infos = FunsAnalysis.analyze_module m fun_decls global_decls !Config.use_state in @@ -33,11 +36,11 @@ let compute_contexts (m : A.crate) : C.decls_ctx = RegionsHierarchy.compute_regions_hierarchies type_decls fun_decls global_decls trait_decls trait_impls in - let fun_ctx = { C.fun_decls; fun_infos; regions_hierarchies } in - let global_ctx = { C.global_decls } in - let trait_decls_ctx = { C.trait_decls } in - let trait_impls_ctx = { C.trait_impls } in - { C.type_ctx; fun_ctx; global_ctx; trait_decls_ctx; trait_impls_ctx } + let fun_ctx = { fun_decls; fun_infos; regions_hierarchies } in + let global_ctx = { global_decls } in + let trait_decls_ctx = { trait_decls } in + let trait_impls_ctx = { trait_impls } in + { type_ctx; fun_ctx; global_ctx; trait_decls_ctx; trait_impls_ctx } (** Small helper. @@ -45,15 +48,14 @@ let compute_contexts (m : A.crate) : C.decls_ctx = to compute a normalization map (for the associated types) and that we added it in the context. *) -let normalize_inst_fun_sig (ctx : C.eval_ctx) (sg : A.inst_fun_sig) : - A.inst_fun_sig = - let { A.regions_hierarchy = _; trait_type_constraints = _; inputs; output } = +let normalize_inst_fun_sig (ctx : eval_ctx) (sg : inst_fun_sig) : inst_fun_sig = + let { regions_hierarchy = _; trait_type_constraints = _; inputs; output } = sg in let norm = AssociatedTypes.ctx_normalize_ty ctx in let inputs = List.map norm inputs in let output = norm output in - { sg with A.inputs; output } + { sg with inputs; output } (** Instantiate a function signature for a symbolic execution. @@ -65,28 +67,28 @@ let normalize_inst_fun_sig (ctx : C.eval_ctx) (sg : A.inst_fun_sig) : clauses (we are not considering a function call, so we don't need to normalize because a trait clause was instantiated with a specific trait ref). *) -let symbolic_instantiate_fun_sig (ctx : C.eval_ctx) (sg : A.fun_sig) - (regions_hierarchy : T.region_groups) (kind : A.fun_kind) : - C.eval_ctx * A.inst_fun_sig = +let symbolic_instantiate_fun_sig (ctx : eval_ctx) (sg : fun_sig) + (regions_hierarchy : region_groups) (kind : fun_kind) : + eval_ctx * inst_fun_sig = let tr_self = match kind with - | RegularKind | TraitMethodImpl _ -> T.UnknownTrait __FUNCTION__ - | TraitMethodDecl _ | TraitMethodProvided _ -> T.Self + | RegularKind | TraitMethodImpl _ -> UnknownTrait __FUNCTION__ + | TraitMethodDecl _ | TraitMethodProvided _ -> Self in let generics = - let { T.regions; types; const_generics; trait_clauses } = sg.generics in - let regions = List.map (fun _ -> T.RErased) regions in - let types = List.map (fun (v : T.type_var) -> T.TVar v.T.index) types in + let { regions; types; const_generics; trait_clauses } = sg.generics in + let regions = List.map (fun _ -> RErased) regions in + let types = List.map (fun (v : type_var) -> TVar v.index) types in let const_generics = - List.map - (fun (v : T.const_generic_var) -> T.CGVar v.T.index) - const_generics + List.map (fun (v : const_generic_var) -> CGVar v.index) const_generics in (* Annoying that we have to generate this substitution here *) let r_subst _ = raise (Failure "Unexpected region") in - let ty_subst = Subst.make_type_subst_from_vars sg.generics.types types in + let ty_subst = + Substitute.make_type_subst_from_vars sg.generics.types types + in let cg_subst = - Subst.make_const_generic_subst_from_vars sg.generics.const_generics + Substitute.make_const_generic_subst_from_vars sg.generics.const_generics const_generics in (* TODO: some clauses may use the types of other clauses, so we may have to @@ -115,39 +117,37 @@ let symbolic_instantiate_fun_sig (ctx : C.eval_ctx) (sg : A.fun_sig) ]} *) (* We will need to update the trait refs map while we perform the instantiations *) - let mk_tr_subst (tr_map : T.trait_instance_id T.TraitClauseId.Map.t) - clause_id : T.trait_instance_id = - match T.TraitClauseId.Map.find_opt clause_id tr_map with + let mk_tr_subst (tr_map : trait_instance_id TraitClauseId.Map.t) clause_id : + trait_instance_id = + match TraitClauseId.Map.find_opt clause_id tr_map with | Some tr -> tr | None -> raise (Failure "Local trait clause not found") in let mk_subst tr_map = let tr_subst = mk_tr_subst tr_map in - { Subst.r_subst; ty_subst; cg_subst; tr_subst; tr_self } + { Substitute.r_subst; ty_subst; cg_subst; tr_subst; tr_self } in let _, trait_refs = List.fold_left_map - (fun tr_map (c : T.trait_clause) -> + (fun tr_map (c : trait_clause) -> let subst = mk_subst tr_map in - let { T.trait_id = trait_decl_id; clause_generics; _ } = c in - let generics = Subst.generic_args_substitute subst clause_generics in - let trait_decl_ref = { T.trait_decl_id; decl_generics = generics } in + let { trait_id = trait_decl_id; clause_generics; _ } = c in + let generics = + Substitute.generic_args_substitute subst clause_generics + in + let trait_decl_ref = { trait_decl_id; decl_generics = generics } in (* Note that because we directly refer to the clause, we give it empty generics *) - let trait_id = T.Clause c.clause_id in + let trait_id = Clause c.clause_id in let trait_ref = - { - T.trait_id; - generics = TypesUtils.mk_empty_generic_args; - trait_decl_ref; - } + { trait_id; generics = empty_generic_args; trait_decl_ref } in (* Update the traits map *) - let tr_map = T.TraitClauseId.Map.add c.T.clause_id trait_id tr_map in + let tr_map = TraitClauseId.Map.add c.clause_id trait_id tr_map in (tr_map, trait_ref)) - T.TraitClauseId.Map.empty trait_clauses + TraitClauseId.Map.empty trait_clauses in - { T.regions; types; const_generics; trait_refs } + { regions; types; const_generics; trait_refs } in let inst_sg = instantiate_fun_sig ctx generics tr_self sg regions_hierarchy in (* Compute the normalization maps *) @@ -173,8 +173,8 @@ let symbolic_instantiate_fun_sig (ctx : C.eval_ctx) (sg : A.fun_sig) - the list of symbolic values introduced for the input values - the instantiated function signature *) -let initialize_symbolic_context_for_fun (ctx : C.decls_ctx) (fdef : A.fun_decl) - : C.eval_ctx * V.symbolic_value list * A.inst_fun_sig = +let initialize_symbolic_context_for_fun (ctx : decls_ctx) (fdef : fun_decl) : + eval_ctx * symbolic_value list * 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 @@ -192,7 +192,7 @@ let initialize_symbolic_context_for_fun (ctx : C.decls_ctx) (fdef : A.fun_decl) FunIdMap.find (FRegular fdef.def_id) ctx.fun_ctx.regions_hierarchies in let region_groups = - List.map (fun (g : T.region_group) -> g.id) regions_hierarchy + List.map (fun (g : region_group) -> g.id) regions_hierarchy in let ctx = initialize_eval_context ctx region_groups sg.generics.types @@ -206,13 +206,13 @@ let initialize_symbolic_context_for_fun (ctx : C.decls_ctx) (fdef : A.fun_decl) 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 + List.map (fun ty -> mk_fresh_symbolic_value 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 = + let call_id = fresh_fun_call_id () in + assert (call_id = FunCallId.zero); + let compute_abs_avalues (abs : abs) (ctx : eval_ctx) : + eval_ctx * 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 @@ -222,8 +222,8 @@ let initialize_symbolic_context_for_fun (ctx : C.decls_ctx) (fdef : A.fun_decl) let region_can_end _ = false in let ctx = create_push_abstractions_from_abs_region_groups - (fun rg_id -> V.SynthInput rg_id) - inst_sg.A.regions_hierarchy region_can_end compute_abs_avalues ctx + (fun rg_id -> SynthInput rg_id) + inst_sg.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 @@ -232,12 +232,12 @@ let initialize_symbolic_context_for_fun (ctx : C.decls_ctx) (fdef : A.fun_decl) 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 + let ctx = 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 + let ctx = 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 + let ctx = ctx_push_uninitialized_vars ctx local_vars in (* Return *) (ctx, input_svs, inst_sg) @@ -253,20 +253,19 @@ let initialize_symbolic_context_for_fun (ctx : C.decls_ctx) (fdef : A.fun_decl) [inside_loop]: [true] if we are *inside* a loop (result [EndContinue]). *) -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) (loop_id : V.LoopId.id option) - (is_regular_return : bool) (inside_loop : bool) (ctx : C.eval_ctx) : - SA.expression option = +let evaluate_function_symbolic_synthesize_backward_from_return (config : config) + (fdef : fun_decl) (inst_sg : inst_fun_sig) (back_id : RegionGroupId.id) + (loop_id : LoopId.id option) (is_regular_return : bool) (inside_loop : bool) + (ctx : eval_ctx) : SA.expression option = log#ldebug (lazy ("evaluate_function_symbolic_synthesize_backward_from_return:" ^ "\n- fname: " - ^ Print.fun_name_to_string fdef.name + ^ Print.EvalCtx.name_to_string ctx fdef.name ^ "\n- back_id: " - ^ T.RegionGroupId.to_string back_id + ^ RegionGroupId.to_string back_id ^ "\n- loop_id: " - ^ Print.option_to_string V.LoopId.to_string loop_id + ^ Print.option_to_string LoopId.to_string loop_id ^ "\n- is_regular_return: " ^ Print.bool_to_string is_regular_return ^ "\n- inside_loop: " @@ -294,9 +293,9 @@ let evaluate_function_symbolic_synthesize_backward_from_return * proper order. *) let parent_rgs = list_ancestor_region_groups regions_hierarchy back_id in let parent_input_abs_ids = - T.RegionGroupId.mapi + RegionGroupId.mapi (fun rg_id rg -> - if T.RegionGroupId.Set.mem rg_id parent_rgs then Some rg.T.id else None) + if RegionGroupId.Set.mem rg_id parent_rgs then Some rg.id else None) inst_sg.regions_hierarchy in let parent_input_abs_ids = @@ -305,12 +304,12 @@ let evaluate_function_symbolic_synthesize_backward_from_return (* Insert the return value in the return abstractions (by applying * borrow projections) *) - let cf_consume_ret (ret_value : V.typed_value option) ctx = + let cf_consume_ret (ret_value : typed_value option) ctx = let ctx = if is_regular_return then ( let ret_value = Option.get ret_value in - let compute_abs_avalues (abs : V.abs) (ctx : C.eval_ctx) : - C.eval_ctx * V.typed_avalue list = + let compute_abs_avalues (abs : abs) (ctx : eval_ctx) : + eval_ctx * typed_avalue list = let ctx, avalue = apply_proj_borrows_on_input_value config ctx abs.regions abs.ancestors_regions ret_value ret_rty @@ -324,18 +323,15 @@ let evaluate_function_symbolic_synthesize_backward_from_return * that this is important for soundness: this is part of the borrow checking). * Also 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 parent_and_current_rgs = RegionGroupId.Set.add back_id parent_rgs in let region_can_end rid = - T.RegionGroupId.Set.mem rid parent_and_current_rgs + RegionGroupId.Set.mem rid parent_and_current_rgs in assert (region_can_end back_id); let ctx = create_push_abstractions_from_abs_region_groups - (fun rg_id -> V.SynthRet rg_id) - ret_inst_sg.A.regions_hierarchy region_can_end compute_abs_avalues - ctx + (fun rg_id -> SynthRet rg_id) + ret_inst_sg.regions_hierarchy region_can_end compute_abs_avalues ctx in ctx) else ctx @@ -356,16 +352,16 @@ let evaluate_function_symbolic_synthesize_backward_from_return *) let current_abs_id, end_fun_synth_input = let fun_abs_id = - (T.RegionGroupId.nth inst_sg.regions_hierarchy back_id).id + (RegionGroupId.nth inst_sg.regions_hierarchy back_id).id in if not inside_loop then (fun_abs_id, true) else - let pred (abs : V.abs) = + let pred (abs : abs) = match abs.kind with - | V.Loop (_, rg_id', kind) -> + | Loop (_, rg_id', kind) -> let rg_id' = Option.get rg_id' in let is_ret = - match kind with V.LoopSynthInput -> true | V.LoopCall -> false + match kind with LoopSynthInput -> true | LoopCall -> false in rg_id' = back_id && is_ret | _ -> false @@ -387,24 +383,24 @@ let evaluate_function_symbolic_synthesize_backward_from_return } ]} *) - let abs = Option.get (C.ctx_find_abs ctx pred) in + let abs = Option.get (ctx_find_abs ctx pred) in (abs.abs_id, false) in log#ldebug (lazy ("evaluate_function_symbolic_synthesize_backward_from_return: ending \ input abstraction: " - ^ V.AbstractionId.to_string current_abs_id)); + ^ AbstractionId.to_string current_abs_id)); (* Set the proper abstractions as endable *) let ctx = let visit_loop_abs = object - inherit [_] C.map_eval_ctx + inherit [_] map_eval_ctx method! visit_abs _ abs = match abs.kind with - | V.Loop (loop_id', rg_id', V.LoopSynthInput) -> + | Loop (loop_id', rg_id', LoopSynthInput) -> (* We only allow to end the loop synth input abs for the region group [rg_id] *) assert ( @@ -415,11 +411,11 @@ let evaluate_function_symbolic_synthesize_backward_from_return if rg_id' = back_id && inside_loop then { abs with can_end = true } else abs - | V.Loop (loop_id', _, V.LoopCall) -> + | Loop (loop_id', _, LoopCall) -> (* We can end all the loop call abstractions *) assert (loop_id = Some loop_id'); { abs with can_end = true } - | V.SynthInput rg_id' -> + | SynthInput rg_id' -> if rg_id' = back_id && end_fun_synth_input then { abs with can_end = true } else abs @@ -456,10 +452,14 @@ let evaluate_function_symbolic_synthesize_backward_from_return for the synthesis) - the symbolic AST generated by the symbolic execution *) -let evaluate_function_symbolic (synthesize : bool) (ctx : C.decls_ctx) - (fdef : A.fun_decl) : V.symbolic_value list * SA.expression option = +let evaluate_function_symbolic (synthesize : bool) (ctx : decls_ctx) + (fdef : fun_decl) : symbolic_value list * SA.expression option = (* Debug *) - let name_to_string () = Print.fun_name_to_string fdef.A.name in + let name_to_string () = + Print.Types.name_to_string + (Print.Contexts.decls_ctx_to_fmt_env ctx) + fdef.name + in log#ldebug (lazy ("evaluate_function_symbolic: " ^ name_to_string ())); (* Create the evaluation context *) @@ -470,8 +470,8 @@ let evaluate_function_symbolic (synthesize : bool) (ctx : C.decls_ctx) in (* Create the continuation to finish the evaluation *) - let config = C.mk_config C.SymbolicMode in - let cf_finish res ctx = + let config = mk_config SymbolicMode in + let cf_finish (res : statement_eval_res) (ctx : eval_ctx) = let ctx0 = ctx in log#ldebug (lazy @@ -523,13 +523,13 @@ let evaluate_function_symbolic (synthesize : bool) (ctx : C.decls_ctx) fdef inst_sg back_id loop_id is_regular_return inside_loop ctx) in let back_el = - T.RegionGroupId.mapi + RegionGroupId.mapi (fun gid _ -> (gid, finish_back_eval gid)) regions_hierarchy in - let back_el = T.RegionGroupId.Map.of_list back_el in + let back_el = RegionGroupId.Map.of_list back_el in (* Put everything together *) - S.synthesize_forward_end ctx0 None fwd_e back_el + synthesize_forward_end ctx0 None fwd_e back_el else None | EndEnterLoop (loop_id, loop_input_values) | EndContinue (loop_id, loop_input_values) -> @@ -567,13 +567,13 @@ let evaluate_function_symbolic (synthesize : bool) (ctx : C.decls_ctx) inside_loop ctx) in let back_el = - T.RegionGroupId.mapi + RegionGroupId.mapi (fun gid _ -> (gid, finish_back_eval gid)) regions_hierarchy in - let back_el = T.RegionGroupId.Map.of_list back_el in + let back_el = RegionGroupId.Map.of_list back_el in (* Put everything together *) - S.synthesize_forward_end ctx0 (Some loop_input_values) fwd_e back_el + synthesize_forward_end ctx0 (Some loop_input_values) fwd_e back_el else None | Panic -> (* Note that as we explore all the execution branches, one of @@ -586,7 +586,7 @@ let evaluate_function_symbolic (synthesize : bool) (ctx : C.decls_ctx) (* Evaluate the function *) let symbolic = - eval_function_body config (Option.get fdef.A.body).body cf_finish ctx + eval_function_body config (Option.get fdef.body).body cf_finish ctx in (* Return *) @@ -596,29 +596,33 @@ module Test = struct (** Test a unit function (taking no arguments) by evaluating it in an empty environment. *) - let test_unit_function (crate : A.crate) (decls_ctx : C.decls_ctx) - (fid : A.FunDeclId.id) : unit = + let test_unit_function (crate : crate) (decls_ctx : decls_ctx) + (fid : FunDeclId.id) : unit = (* Retrieve the function declaration *) - let fdef = A.FunDeclId.Map.find fid crate.functions in + let fdef = FunDeclId.Map.find fid crate.fun_decls in let body = Option.get fdef.body in (* Debug *) log#ldebug - (lazy ("test_unit_function: " ^ Print.fun_name_to_string fdef.A.name)); + (lazy + ("test_unit_function: " + ^ Print.Types.name_to_string + (Print.Contexts.decls_ctx_to_fmt_env decls_ctx) + fdef.name)); (* Sanity check - *) - assert (fdef.A.signature.generics = TypesUtils.mk_empty_generic_params); - assert (body.A.arg_count = 0); + assert (fdef.signature.generics = empty_generic_params); + assert (body.arg_count = 0); (* Create the evaluation context *) let ctx = initialize_eval_context decls_ctx [] [] [] in (* Insert the (uninitialized) local variables *) - let ctx = C.ctx_push_uninitialized_vars ctx body.A.locals in + let ctx = ctx_push_uninitialized_vars ctx body.locals in (* Create the continuation to check the function's result *) - let config = C.mk_config C.ConcreteMode in - let cf_check res ctx = + let config = mk_config ConcreteMode in + let cf_check (res : statement_eval_res) (ctx : eval_ctx) = match res with | Return -> (* Ok: drop the local variables and finish *) @@ -628,7 +632,9 @@ module Test = struct raise (Failure ("Unit test failed (concrete execution) on: " - ^ Print.fun_name_to_string fdef.A.name)) + ^ Print.Types.name_to_string + (Print.Contexts.decls_ctx_to_fmt_env decls_ctx) + fdef.name)) in (* Evaluate the function *) @@ -637,21 +643,21 @@ module Test = struct (** 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 = + let fun_decl_is_transparent_unit (def : fun_decl) : bool = Option.is_some def.body - && def.A.signature.generics = TypesUtils.mk_empty_generic_params - && def.A.signature.inputs = [] + && def.signature.generics = empty_generic_params + && def.signature.inputs = [] (** Test all the unit functions in a list of function definitions *) - let test_unit_functions (crate : A.crate) : unit = + let test_unit_functions (crate : crate) : unit = let unit_funs = - A.FunDeclId.Map.filter + FunDeclId.Map.filter (fun _ -> fun_decl_is_transparent_unit) - crate.functions + crate.fun_decls in let decls_ctx = compute_contexts crate in - let test_unit_fun _ (def : A.fun_decl) : unit = - test_unit_function crate decls_ctx def.A.def_id + let test_unit_fun _ (def : fun_decl) : unit = + test_unit_function crate decls_ctx def.def_id in - A.FunDeclId.Map.iter test_unit_fun unit_funs + FunDeclId.Map.iter test_unit_fun unit_funs end diff --git a/compiler/InterpreterBorrows.ml b/compiler/InterpreterBorrows.ml index 566061c2..8c9c0e72 100644 --- a/compiler/InterpreterBorrows.ml +++ b/compiler/InterpreterBorrows.ml @@ -1,9 +1,6 @@ -module T = Types -module V = Values -module C = Contexts -module Subst = Substitute -module L = Logging -module S = SynthesizeSymbolic +open Types +open Values +open Contexts open Cps open ValuesUtils open TypesUtils @@ -12,11 +9,11 @@ open InterpreterBorrowsCore open InterpreterProjectors (** The local logger *) -let log = L.borrows_log +let log = Logging.borrows_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 + replaced by {!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_aux] then simply performs a loop: as long as we need to end (outer) @@ -32,18 +29,18 @@ let log = L.borrows_log loans. This is used to merge borrows with abstractions, to compute loop fixed points for instance. *) -let end_borrow_get_borrow (allowed_abs : V.AbstractionId.id option) - (allow_inner_loans : bool) (l : V.BorrowId.id) (ctx : C.eval_ctx) : - ( C.eval_ctx * (V.AbstractionId.id option * g_borrow_content) option, +let end_borrow_get_borrow (allowed_abs : AbstractionId.id option) + (allow_inner_loans : bool) (l : BorrowId.id) (ctx : eval_ctx) : + ( eval_ctx * (AbstractionId.id option * 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 : (V.AbstractionId.id option * g_borrow_content) option ref = + let replaced_bc : (AbstractionId.id option * g_borrow_content) option ref = ref None in - let set_replaced_bc (abs_id : V.AbstractionId.id option) - (bc : g_borrow_content) = + let set_replaced_bc (abs_id : AbstractionId.id option) (bc : g_borrow_content) + = assert (Option.is_none !replaced_bc); replaced_bc := Some (abs_id, bc) in @@ -52,8 +49,8 @@ let end_borrow_get_borrow (allowed_abs : V.AbstractionId.id option) * - 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) = + let raise_if_priority (outer : AbstractionId.id option * borrow_ids option) + (borrowed_value : typed_value option) = (* First, look for outer borrows or abstraction *) let outer_abs, outer_borrows = outer in (match outer_abs with @@ -88,12 +85,12 @@ let end_borrow_get_borrow (allowed_abs : V.AbstractionId.id option) (* The environment is used to keep track of the outer loans *) let obj = object - inherit [_] C.map_eval_ctx as super + inherit [_] map_eval_ctx as super (** We reimplement {!visit_Loan} because we may have to update the outer borrows *) - method! visit_VLoan - (outer : V.AbstractionId.id option * borrow_ids option) lc = + method! visit_VLoan (outer : AbstractionId.id option * borrow_ids option) + lc = match lc with | VMutLoan bid -> VLoan (super#visit_VMutLoan outer bid) | VSharedLoan (bids, v) -> @@ -228,7 +225,7 @@ let end_borrow_get_borrow (allowed_abs : V.AbstractionId.id option) 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 + let outer = (Some abs.abs_id, None) in super#visit_abs outer abs end in @@ -247,15 +244,15 @@ let end_borrow_get_borrow (allowed_abs : V.AbstractionId.id option) 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 = +let give_back_value (config : config) (bid : BorrowId.id) (nv : typed_value) + (ctx : eval_ctx) : 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: " + ("give_back_value:\n- bid: " ^ 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 *) @@ -274,17 +271,17 @@ let give_back_value (config : C.config) (bid : V.BorrowId.id) (* The visitor to give back the values *) let obj = object (self) - inherit [_] C.map_eval_ctx as super + inherit [_] 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 + method! visit_typed_value opt_abs (v : typed_value) : typed_value = + match v.value with | VLoan lc -> - let value = self#visit_typed_Loan opt_abs v.V.ty lc in - ({ v with V.value } : V.typed_value) + let value = self#visit_typed_Loan opt_abs v.ty lc in + ({ v with value } : typed_value) | _ -> super#visit_typed_value opt_abs v method visit_typed_Loan opt_abs ty lc = @@ -301,8 +298,8 @@ let give_back_value (config : C.config) (bid : V.BorrowId.id) if nv.ty <> expected_ty then ( log#serror ("give_back_value: improper type:\n- expected: " - ^ PA.ty_to_string ctx ty ^ "\n- received: " - ^ PA.ty_to_string ctx nv.ty); + ^ ty_to_string ctx ty ^ "\n- received: " + ^ ty_to_string ctx nv.ty); raise (Failure "Value given back doesn't have the proper type")); (* Replace *) set_replaced (); @@ -313,26 +310,25 @@ let give_back_value (config : C.config) (bid : V.BorrowId.id) 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) + method! visit_typed_avalue opt_abs (av : typed_avalue) : typed_avalue = + match av.value with + | ALoan lc -> + let value = self#visit_typed_ALoan opt_abs av.ty lc in + ({ av with value } : 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 = + method! visit_ABorrow (opt_abs : abs option) (bc : aborrow_content) + : avalue = match bc with - | V.AIgnoredMutBorrow (bid', child) -> + | 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 + match nv.value with | VSymbolic sv -> let abs = Option.get opt_abs in (* Remember the given back value as a meta-value @@ -346,26 +342,26 @@ let give_back_value (config : C.config) (bid : V.BorrowId.id) (* Continue giving back in the child value *) let child = super#visit_typed_avalue opt_abs child in (* Return *) - V.ABorrow - (V.AEndedIgnoredMutBorrow + ABorrow + (AEndedIgnoredMutBorrow { given_back; child; given_back_meta }) | _ -> raise (Failure "Unreachable") else (* Continue exploring *) - V.ABorrow (super#visit_AIgnoredMutBorrow opt_abs bid' child) + 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 = + method visit_typed_ALoan (opt_abs : abs option) (ty : rty) + (lc : aloan_content) : avalue = (* Preparing a bit *) let regions, ancestors_regions = match opt_abs with | None -> raise (Failure "Unreachable") - | Some abs -> (abs.V.regions, abs.V.ancestors_regions) + | Some abs -> (abs.regions, abs.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} *) @@ -443,13 +439,13 @@ let give_back_value (config : C.config) (bid : V.BorrowId.id) 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 = +let give_back_symbolic_value (_config : config) (proj_regions : RegionId.Set.t) + (proj_ty : rty) (sv : symbolic_value) (nsv : symbolic_value) + (ctx : eval_ctx) : eval_ctx = (* Sanity checks *) assert (sv.sv_id <> nsv.sv_id && ty_is_rty proj_ty); (match nsv.sv_kind with - | V.SynthInputGivenBack | SynthRetGivenBack | FunCallGivenBack | LoopGivenBack + | SynthInputGivenBack | SynthRetGivenBack | FunCallGivenBack | LoopGivenBack -> () | FunCallRet | SynthInput | Global | LoopOutput | LoopJoin | Aggregate @@ -458,13 +454,13 @@ let give_back_symbolic_value (_config : C.config) (* 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 = + let subst (_abs : abs) local_given_back = (* See the below comments: there is something wrong here *) let _ = raise Utils.Unimplemented in (* Compute the projection over the given back value *) let child_proj = match nsv.sv_kind with - | V.SynthRetGivenBack -> + | 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 @@ -472,8 +468,8 @@ let give_back_symbolic_value (_config : C.config) As we don't allow borrow overwrites on returned value, we can (and MUST) forget the borrows *) - V.AIgnoredProjBorrows - | V.FunCallGivenBack -> + AIgnoredProjBorrows + | FunCallGivenBack -> (* TODO: there is something wrong here. Consider this: {[ @@ -486,16 +482,16 @@ let give_back_symbolic_value (_config : C.config) 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) + AProjBorrows (nsv, sv.sv_ty) | _ -> raise (Failure "Unreachable") in - V.AProjLoans (sv, (mv, child_proj) :: local_given_back) + 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} + This function is similar to {!give_back_value} but gives back an {!avalue} (coming from an abstraction). It is used when ending a borrow inside an abstraction, when the corresponding @@ -504,11 +500,10 @@ let give_back_symbolic_value (_config : C.config) 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. + to convert the {!avalue} to a {!type:value} by introducing the proper symbolic values. *) -let give_back_avalue_to_same_abstraction (_config : C.config) - (bid : V.BorrowId.id) (nv : V.typed_avalue) (nsv : V.typed_value) - (ctx : C.eval_ctx) : C.eval_ctx = +let give_back_avalue_to_same_abstraction (_config : config) (bid : BorrowId.id) + (nv : typed_avalue) (nsv : typed_value) (ctx : eval_ctx) : eval_ctx = (* We use a reference to check that we updated exactly one loan *) let replaced : bool ref = ref false in let set_replaced () = @@ -517,7 +512,7 @@ let give_back_avalue_to_same_abstraction (_config : C.config) in let obj = object (self) - inherit [_] C.map_eval_ctx as super + inherit [_] 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 @@ -527,12 +522,11 @@ let give_back_avalue_to_same_abstraction (_config : C.config) TODO: it is possible to do this by remembering the type of the last typed avalue we entered. *) - 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) + method! visit_typed_avalue opt_abs (av : typed_avalue) : typed_avalue = + match av.value with + | ALoan lc -> + let value = self#visit_typed_ALoan opt_abs av.ty lc in + ({ av with value } : typed_avalue) | _ -> super#visit_typed_avalue opt_abs av (** We are not specializing an already existing method, but adding a @@ -541,21 +535,21 @@ let give_back_avalue_to_same_abstraction (_config : C.config) TODO: it is possible to do this by remembering the type of the last typed avalue we entered. *) - method visit_typed_ALoan (opt_abs : V.abs option) (ty : T.rty) - (lc : V.aloan_content) : V.avalue = + method visit_typed_ALoan (opt_abs : abs option) (ty : rty) + (lc : aloan_content) : avalue = match lc with - | V.AMutLoan (bid', child) -> + | 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 ( + if nv.ty <> expected_ty then ( log#serror ("give_back_avalue_to_same_abstraction: improper type:\n\ - - expected: " ^ PA.ty_to_string ctx ty ^ "\n- received: " - ^ PA.ty_to_string ctx nv.V.ty); + - expected: " ^ ty_to_string ctx ty ^ "\n- received: " + ^ ty_to_string ctx nv.ty); raise (Failure "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 @@ -563,18 +557,17 @@ let give_back_avalue_to_same_abstraction (_config : C.config) (* Register the insertion *) set_replaced (); (* Return the new value *) - V.ALoan - (V.AEndedMutLoan - { given_back = nv; child; given_back_meta = nsv })) + ALoan + (AEndedMutLoan { given_back = nv; child; given_back_meta = nsv })) else (* Continue exploring *) super#visit_ALoan opt_abs lc - | V.ASharedLoan (_, _, _) + | 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 (_, _) -> + | AEndedMutLoan { given_back = _; child = _; given_back_meta = _ } + | AEndedSharedLoan (_, _) -> (* Nothing special to do *) super#visit_ALoan opt_abs lc - | V.AIgnoredMutLoan (bid_opt, child) -> + | AIgnoredMutLoan (bid_opt, child) -> (* This loan is ignored, but we may have to project on a subvalue * of the value which is given back *) if bid_opt = Some bid then ( @@ -583,14 +576,14 @@ let give_back_avalue_to_same_abstraction (_config : C.config) * 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 + assert (nv.ty = ty); + ALoan + (AEndedIgnoredMutLoan { given_back = nv; child; given_back_meta = nsv })) else super#visit_ALoan opt_abs lc - | V.AEndedIgnoredMutLoan + | AEndedIgnoredMutLoan { given_back = _; child = _; given_back_meta = _ } - | V.AIgnoredSharedLoan _ -> + | AIgnoredSharedLoan _ -> (* Nothing special to do *) super#visit_ALoan opt_abs lc end @@ -612,8 +605,7 @@ let give_back_avalue_to_same_abstraction (_config : C.config) 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 = +let give_back_shared _config (bid : BorrowId.id) (ctx : eval_ctx) : eval_ctx = (* We use a reference to check that we updated exactly one loan *) let replaced : bool ref = ref false in let set_replaced () = @@ -622,21 +614,20 @@ let give_back_shared _config (bid : V.BorrowId.id) (ctx : C.eval_ctx) : in let obj = object - inherit [_] C.map_eval_ctx as super + inherit [_] map_eval_ctx as super method! visit_VLoan opt_abs lc = match lc with | VSharedLoan (bids, shared_value) -> - if V.BorrowId.Set.mem bid bids then ( + if 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 + if BorrowId.Set.cardinal bids = 1 then shared_value.value else - VLoan - (VSharedLoan (V.BorrowId.Set.remove bid bids, shared_value))) + VLoan (VSharedLoan (BorrowId.Set.remove bid bids, shared_value))) else (* Not the loan we are looking for: continue exploring *) VLoan (super#visit_VSharedLoan opt_abs bids shared_value) @@ -650,18 +641,18 @@ let give_back_shared _config (bid : V.BorrowId.id) (ctx : C.eval_ctx) : (* Nothing special to do (we are giving back a *shared* borrow) *) ALoan (super#visit_AMutLoan opt_abs bid av) | ASharedLoan (bids, shared_value, child) -> - if V.BorrowId.Set.mem bid bids then ( + if 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 + if BorrowId.Set.cardinal bids = 1 then ALoan (AEndedSharedLoan (shared_value, child)) else ALoan (ASharedLoan - (V.BorrowId.Set.remove bid bids, shared_value, child))) + (BorrowId.Set.remove bid bids, shared_value, child))) else (* Not the loan we are looking for: continue exploring *) super#visit_ALoan opt_abs lc @@ -692,8 +683,8 @@ let give_back_shared _config (bid : V.BorrowId.id) (ctx : C.eval_ctx) : 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 = +let reborrow_shared (original_bid : BorrowId.id) (new_bid : BorrowId.id) + (ctx : eval_ctx) : eval_ctx = (* Keep track of changes *) let r = ref false in let set_ref () = @@ -703,24 +694,24 @@ let reborrow_shared (original_bid : V.BorrowId.id) (new_bid : V.BorrowId.id) let obj = object - inherit [_] C.map_env as super + inherit [_] map_env as super method! visit_VSharedLoan 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 ( + if BorrowId.Set.mem original_bid bids then ( set_ref (); - let bids' = V.BorrowId.Set.add new_bid bids in + let bids' = BorrowId.Set.add new_bid bids in VSharedLoan (bids', sv)) else super#visit_VSharedLoan 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 ( + if BorrowId.Set.mem original_bid bids then ( set_ref (); - let bids' = V.BorrowId.Set.add new_bid bids in - V.ASharedLoan (bids', v, av)) + let bids' = BorrowId.Set.add new_bid bids in + ASharedLoan (bids', v, av)) else super#visit_ASharedLoan env bids v av end in @@ -730,11 +721,11 @@ let reborrow_shared (original_bid : V.BorrowId.id) (new_bid : V.BorrowId.id) assert !r; { ctx with env } -(** Convert an {!type:V.avalue} to a {!type:V.value}. +(** Convert an {!type:avalue} to a {!type: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. + in an abstraction, we converted the borrowed {!avalue} to a fresh symbolic + {!type:value}, then give back this {!type:value} to the context. Note that some regions may have ended in the symbolic value we generate. For instance, consider the following function signature: @@ -746,19 +737,19 @@ let reborrow_shared (original_bid : V.BorrowId.id) (new_bid : V.BorrowId.id) 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 convert_avalue_to_given_back_value (abs_kind : abs_kind) (av : typed_avalue) + : symbolic_value = let sv_kind = match abs_kind with - | V.FunCall _ -> V.FunCallGivenBack - | V.SynthRet _ -> V.SynthRetGivenBack - | V.SynthInput _ -> V.SynthInputGivenBack - | V.Loop _ -> V.LoopGivenBack - | V.Identity -> + | FunCall _ -> FunCallGivenBack + | SynthRet _ -> SynthRetGivenBack + | SynthInput _ -> SynthInputGivenBack + | Loop _ -> LoopGivenBack + | Identity -> (* Identity abstractions give back nothing *) raise (Failure "Unreachable") in - mk_fresh_symbolic_value sv_kind av.V.ty + mk_fresh_symbolic_value sv_kind av.ty (** Auxiliary function: see {!end_borrow_aux}. @@ -776,9 +767,8 @@ let convert_avalue_to_given_back_value (abs_kind : V.abs_kind) borrows. This kind of internal reshuffling. should be similar to ending abstractions (it is tantamount to ending *sub*-abstractions). *) -let give_back (config : C.config) (abs_id_opt : V.AbstractionId.id option) - (l : V.BorrowId.id) (bc : g_borrow_content) (ctx : C.eval_ctx) : C.eval_ctx - = +let give_back (config : config) (abs_id_opt : AbstractionId.id option) + (l : BorrowId.id) (bc : g_borrow_content) (ctx : eval_ctx) : eval_ctx = (* Debug *) log#ldebug (lazy @@ -787,7 +777,7 @@ let give_back (config : C.config) (abs_id_opt : V.AbstractionId.id option) | 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 + "give_back:\n- bid: " ^ 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 = @@ -820,7 +810,7 @@ let give_back (config : C.config) (abs_id_opt : V.AbstractionId.id option) which takes care of ending *sub*-abstractions. *) let abs_id = Option.get abs_id_opt in - let abs = C.ctx_lookup_abs ctx abs_id in + let abs = ctx_lookup_abs ctx abs_id in let sv = convert_avalue_to_given_back_value abs.kind av in (* Update the context *) give_back_avalue_to_same_abstraction config l av @@ -843,16 +833,16 @@ let give_back (config : C.config) (abs_id_opt : V.AbstractionId.id option) | AEndedSharedBorrow ) -> raise (Failure "Unreachable") -let check_borrow_disappeared (fun_name : string) (l : V.BorrowId.id) - (ctx0 : C.eval_ctx) : cm_fun = - let check_disappeared (ctx : C.eval_ctx) : unit = +let check_borrow_disappeared (fun_name : string) (l : BorrowId.id) + (ctx0 : eval_ctx) : cm_fun = + let check_disappeared (ctx : eval_ctx) : unit = let _ = match lookup_borrow_opt ek_all l ctx with | None -> () (* Ok *) | Some _ -> log#lerror (lazy - (fun_name ^ ": " ^ V.BorrowId.to_string l + (fun_name ^ ": " ^ 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)); @@ -863,7 +853,7 @@ let check_borrow_disappeared (fun_name : string) (l : V.BorrowId.id) | Some _ -> log#lerror (lazy - (fun_name ^ ": " ^ V.BorrowId.to_string l + (fun_name ^ ": " ^ 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)); @@ -892,8 +882,8 @@ let check_borrow_disappeared (fun_name : string) (l : V.BorrowId.id) perform anything smart and is trusted, and another function for the book-keeping. *) -let rec end_borrow_aux (config : C.config) (chain : borrow_or_abs_ids) - (allowed_abs : V.AbstractionId.id option) (l : V.BorrowId.id) : cm_fun = +let rec end_borrow_aux (config : config) (chain : borrow_or_abs_ids) + (allowed_abs : AbstractionId.id option) (l : BorrowId.id) : cm_fun = fun cf ctx -> (* Check that we don't loop *) let chain0 = chain in @@ -902,7 +892,7 @@ let rec end_borrow_aux (config : C.config) (chain : borrow_or_abs_ids) in log#ldebug (lazy - ("end borrow: " ^ V.BorrowId.to_string l ^ ":\n- original context:\n" + ("end borrow: " ^ BorrowId.to_string l ^ ":\n- original context:\n" ^ eval_ctx_to_string ctx)); (* Utility function for the sanity checks: check that the borrow disappeared @@ -928,7 +918,7 @@ let rec end_borrow_aux (config : C.config) (chain : borrow_or_abs_ids) (* Debug *) log#ldebug (lazy - ("end borrow: " ^ V.BorrowId.to_string l + ("end borrow: " ^ BorrowId.to_string l ^ ": found outer borrows/abs or inner loans:" ^ show_priority_borrows_or_abs priority)); (* End the priority borrows, abstractions, then try again to end the target @@ -978,20 +968,19 @@ let rec end_borrow_aux (config : C.config) (chain : borrow_or_abs_ids) (* Do a sanity check and continue *) cf_check cf ctx -and end_borrows_aux (config : C.config) (chain : borrow_or_abs_ids) - (allowed_abs : V.AbstractionId.id option) (lset : V.BorrowId.Set.t) : cm_fun - = +and end_borrows_aux (config : config) (chain : borrow_or_abs_ids) + (allowed_abs : AbstractionId.id option) (lset : 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 + let ids = BorrowId.Set.fold (fun id ids -> id :: ids) lset [] in List.fold_left (fun cf id -> end_borrow_aux config chain allowed_abs id cf) cf ids -and end_abstraction_aux (config : C.config) (chain : borrow_or_abs_ids) - (abs_id : V.AbstractionId.id) : cm_fun = +and end_abstraction_aux (config : config) (chain : borrow_or_abs_ids) + (abs_id : AbstractionId.id) : cm_fun = fun cf ctx -> (* Check that we don't loop *) let chain = @@ -1002,11 +991,11 @@ and end_abstraction_aux (config : C.config) (chain : borrow_or_abs_ids) log#ldebug (lazy ("end_abstraction_aux: " - ^ V.AbstractionId.to_string abs_id + ^ 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 + let abs = ctx_lookup_abs ctx abs_id in (* Check that we can end the abstraction *) if abs.can_end then () @@ -1014,7 +1003,7 @@ and end_abstraction_aux (config : C.config) (chain : borrow_or_abs_ids) raise (Failure ("Can't end abstraction " - ^ V.AbstractionId.to_string abs.abs_id + ^ AbstractionId.to_string abs.abs_id ^ " as it is set as non-endable")); (* End the parent abstractions first *) @@ -1024,7 +1013,7 @@ and end_abstraction_aux (config : C.config) (chain : borrow_or_abs_ids) log#ldebug (lazy ("end_abstraction_aux: " - ^ V.AbstractionId.to_string abs_id + ^ AbstractionId.to_string abs_id ^ "\n- context after parent abstractions ended:\n" ^ eval_ctx_to_string ctx))) in @@ -1036,7 +1025,7 @@ and end_abstraction_aux (config : C.config) (chain : borrow_or_abs_ids) log#ldebug (lazy ("end_abstraction_aux: " - ^ V.AbstractionId.to_string abs_id + ^ AbstractionId.to_string abs_id ^ "\n- context after loans ended:\n" ^ eval_ctx_to_string ctx))) in @@ -1048,9 +1037,7 @@ and end_abstraction_aux (config : C.config) (chain : borrow_or_abs_ids) * changes... *) let cc = comp_update cc (fun ctx -> - let ended_regions = - T.RegionId.Set.union ctx.ended_regions abs.V.regions - in + let ended_regions = RegionId.Set.union ctx.ended_regions abs.regions in { ctx with ended_regions }) in @@ -1065,7 +1052,7 @@ and end_abstraction_aux (config : C.config) (chain : borrow_or_abs_ids) log#ldebug (lazy ("end_abstraction_aux: " - ^ V.AbstractionId.to_string abs_id + ^ 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 @@ -1076,22 +1063,22 @@ and end_abstraction_aux (config : C.config) (chain : borrow_or_abs_ids) (* Apply the continuation *) cc cf ctx -and end_abstractions_aux (config : C.config) (chain : borrow_or_abs_ids) - (abs_ids : V.AbstractionId.Set.t) : cm_fun = +and end_abstractions_aux (config : config) (chain : borrow_or_abs_ids) + (abs_ids : 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 + let abs_ids = AbstractionId.Set.fold (fun id ids -> id :: ids) abs_ids [] in List.fold_left (fun cf id -> end_abstraction_aux 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 = +and end_abstraction_loans (config : config) (chain : borrow_or_abs_ids) + (abs_id : AbstractionId.id) : cm_fun = fun cf ctx -> (* Lookup the abstraction *) - let abs = C.ctx_lookup_abs ctx abs_id in + let abs = 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 @@ -1121,12 +1108,12 @@ and end_abstraction_loans (config : C.config) (chain : borrow_or_abs_ids) (* Continue *) cc cf ctx -and end_abstraction_borrows (config : C.config) (chain : borrow_or_abs_ids) - (abs_id : V.AbstractionId.id) : cm_fun = +and end_abstraction_borrows (config : config) (chain : borrow_or_abs_ids) + (abs_id : AbstractionId.id) : cm_fun = fun cf ctx -> log#ldebug (lazy - ("end_abstraction_borrows: abs_id: " ^ V.AbstractionId.to_string abs_id)); + ("end_abstraction_borrows: abs_id: " ^ 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. @@ -1146,7 +1133,7 @@ and end_abstraction_borrows (config : C.config) (chain : borrow_or_abs_ids) *) let obj = object - inherit [_] V.iter_abs as super + inherit [_] iter_abs as super method! visit_aborrow_content env bc = (* In-depth exploration *) @@ -1154,29 +1141,27 @@ and end_abstraction_borrows (config : C.config) (chain : borrow_or_abs_ids) (* No exception was raise: we can raise an exception for the * current borrow *) match bc with - | V.AMutBorrow _ | V.ASharedBorrow _ -> + | AMutBorrow _ | ASharedBorrow _ -> (* Raise an exception *) raise (FoundABorrowContent bc) - | V.AProjSharedBorrow asb -> + | AProjSharedBorrow asb -> (* Raise an exception only if the asb contains borrows *) if List.exists - (fun x -> match x with V.AsbBorrow _ -> true | _ -> false) + (fun x -> match x with AsbBorrow _ -> true | _ -> false) asb then raise (FoundABorrowContent bc) else () - | V.AEndedMutBorrow _ | V.AIgnoredMutBorrow _ - | V.AEndedIgnoredMutBorrow _ | V.AEndedSharedBorrow -> + | AEndedMutBorrow _ | AIgnoredMutBorrow _ | AEndedIgnoredMutBorrow _ + | AEndedSharedBorrow -> (* Nothing to do for ignored borrows *) () method! visit_aproj env sproj = (match sproj with - | V.AProjLoans _ -> raise (Failure "Unexpected") - | V.AProjBorrows (sv, proj_ty) -> - raise (FoundAProjBorrows (sv, proj_ty)) - | V.AEndedProjLoans _ | V.AEndedProjBorrows _ | V.AIgnoredProjBorrows -> - ()); + | AProjLoans _ -> raise (Failure "Unexpected") + | AProjBorrows (sv, proj_ty) -> raise (FoundAProjBorrows (sv, proj_ty)) + | AEndedProjLoans _ | AEndedProjBorrows _ | AIgnoredProjBorrows -> ()); super#visit_aproj env sproj (** We may need to end borrows in "regular" values, because of shared values *) @@ -1187,7 +1172,7 @@ and end_abstraction_borrows (config : C.config) (chain : borrow_or_abs_ids) end in (* Lookup the abstraction *) - let abs = C.ctx_lookup_abs ctx abs_id in + let abs = ctx_lookup_abs ctx abs_id in try (* Explore the abstraction, looking for borrows *) obj#visit_abs () abs; @@ -1202,37 +1187,37 @@ and end_abstraction_borrows (config : C.config) (chain : borrow_or_abs_ids) ^ aborrow_content_to_string ctx bc)); let ctx = match bc with - | V.AMutBorrow (bid, av) -> + | AMutBorrow (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 ended_borrow = ABorrow (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 -> + | ASharedBorrow bid -> (* Replace the shared borrow to account for the fact it ended *) - let ended_borrow = V.ABorrow V.AEndedSharedBorrow in + let ended_borrow = ABorrow AEndedSharedBorrow in let ctx = update_aborrow ek_all bid ended_borrow ctx in (* Give back *) give_back_shared config bid ctx - | V.AProjSharedBorrow asb -> + | AProjSharedBorrow asb -> (* Retrieve the borrow ids *) let bids = List.filter_map (fun asb -> match asb with - | V.AsbBorrow bid -> Some bid - | V.AsbProjReborrows (_, _) -> None) + | AsbBorrow bid -> Some bid + | 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 + let ctx = update_aborrow ek_all repr_bid ABottom ctx in (* Give back the shared borrows *) let ctx = List.fold_left @@ -1241,8 +1226,8 @@ and end_abstraction_borrows (config : C.config) (chain : borrow_or_abs_ids) in (* Continue *) ctx - | V.AEndedMutBorrow _ | V.AIgnoredMutBorrow _ - | V.AEndedIgnoredMutBorrow _ | V.AEndedSharedBorrow -> + | AEndedMutBorrow _ | AIgnoredMutBorrow _ | AEndedIgnoredMutBorrow _ + | AEndedSharedBorrow -> raise (Failure "Unexpected") in (* Reexplore *) @@ -1252,11 +1237,11 @@ and end_abstraction_borrows (config : C.config) (chain : borrow_or_abs_ids) log#ldebug (lazy ("end_abstraction_borrows: found aproj borrows: " - ^ aproj_to_string ctx (V.AProjBorrows (sv, proj_ty)))); + ^ aproj_to_string ctx (AProjBorrows (sv, proj_ty)))); (* Generate a fresh symbolic value *) - let nsv = mk_fresh_symbolic_value V.FunCallGivenBack proj_ty in + let nsv = mk_fresh_symbolic_value FunCallGivenBack proj_ty in (* Replace the proj_borrows - there should be exactly one *) - let ended_borrow = V.AEndedProjBorrows nsv in + let ended_borrow = AEndedProjBorrows nsv in let ctx = update_aproj_borrows abs.abs_id sv ended_borrow ctx in (* Give back the symbolic value *) let ctx = @@ -1299,15 +1284,15 @@ and end_abstraction_borrows (config : C.config) (chain : borrow_or_abs_ids) 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 = +and end_abstraction_remove_from_context (_config : config) + (abs_id : AbstractionId.id) : cm_fun = fun cf ctx -> - let ctx, abs = C.ctx_remove_abs ctx abs_id in + let ctx, abs = ctx_remove_abs ctx abs_id in let abs = Option.get abs in (* Apply the continuation *) let expr = cf ctx in (* Synthesize the symbolic AST *) - S.synthesize_end_abstraction ctx abs expr + SynthesizeSymbolic.synthesize_end_abstraction ctx abs expr (** End a proj_loan over a symbolic value by ending the proj_borrows which intersect this proj_loans. @@ -1323,9 +1308,9 @@ and end_abstraction_remove_from_context (_config : C.config) 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 = +and end_proj_loans_symbolic (config : config) (chain : borrow_or_abs_ids) + (abs_id : AbstractionId.id) (regions : RegionId.Set.t) (sv : symbolic_value) + : cm_fun = fun cf ctx -> (* Small helpers for sanity checks *) let check ctx = no_aproj_over_symbolic_in_context sv ctx in @@ -1382,8 +1367,8 @@ and end_proj_loans_symbolic (config : C.config) (chain : borrow_or_abs_ids) 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 + (fun s id -> AbstractionId.Set.add id s) + AbstractionId.Set.empty abs_ids in (* End the abstractions and continue *) end_abstractions_aux config chain abs_ids cf ctx @@ -1426,7 +1411,7 @@ and end_proj_loans_symbolic (config : C.config) (chain : borrow_or_abs_ids) *) (* 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 + let ctx = update_aproj_borrows abs_id sv AIgnoredProjBorrows ctx in (* Sanity check: no other occurrence of an intersecting projector of borrows *) assert ( Option.is_none @@ -1449,9 +1434,9 @@ and end_proj_loans_symbolic (config : C.config) (chain : borrow_or_abs_ids) (* Continue *) cc cf ctx -let end_borrow config : V.BorrowId.id -> cm_fun = end_borrow_aux config [] None +let end_borrow config : BorrowId.id -> cm_fun = end_borrow_aux config [] None -let end_borrows config : V.BorrowId.Set.t -> cm_fun = +let end_borrows config : BorrowId.Set.t -> cm_fun = end_borrows_aux config [] None let end_abstraction config = end_abstraction_aux config [] @@ -1478,20 +1463,20 @@ let end_abstractions_no_synth config ids ctx = The returned value (previously shared) is checked: - it mustn't contain loans - - it mustn't contain {!V.Bottom} + - it mustn't contain {!Bottom} - it mustn't contain reserved 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 = +let promote_shared_loan_to_mut_loan (l : BorrowId.id) + (cf : 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 + ("promote_shared_loan_to_mut_loan:\n- loan: " ^ 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. @@ -1505,7 +1490,7 @@ let promote_shared_loan_to_mut_loan (l : V.BorrowId.id) raise (Failure "Expected a shared loan, found a mut loan") | _, Concrete (VSharedLoan (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); + assert (BorrowId.Set.mem l bids && 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. *) @@ -1531,8 +1516,8 @@ let promote_shared_loan_to_mut_loan (l : V.BorrowId.id) This function updates a shared borrow to a mutable borrow (and that is all: it doesn't touch the corresponding loan). *) -let replace_reserved_borrow_with_mut_borrow (l : V.BorrowId.id) (cf : m_fun) - (borrowed_value : V.typed_value) : m_fun = +let replace_reserved_borrow_with_mut_borrow (l : BorrowId.id) (cf : m_fun) + (borrowed_value : typed_value) : m_fun = fun ctx -> (* Lookup the reserved borrow - note that we don't go inside borrows/loans: there can't be reserved borrows inside other borrows/loans @@ -1558,8 +1543,8 @@ let replace_reserved_borrow_with_mut_borrow (l : V.BorrowId.id) (cf : m_fun) cf ctx (** Promote a reserved mut borrow to a mut borrow. *) -let rec promote_reserved_mut_borrow (config : C.config) (l : V.BorrowId.id) : - cm_fun = +let rec promote_reserved_mut_borrow (config : config) (l : BorrowId.id) : cm_fun + = fun cf ctx -> (* Lookup the value *) let ek = @@ -1595,7 +1580,7 @@ let rec promote_reserved_mut_borrow (config : C.config) (l : V.BorrowId.id) : assert (not (reserved_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 bids = BorrowId.Set.remove l bids in let cc = end_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 @@ -1619,9 +1604,8 @@ let rec promote_reserved_mut_borrow (config : C.config) (l : V.BorrowId.id) : "Can't activate a reserved mutable borrow referencing a loan inside\n\ \ an abstraction") -let destructure_abs (abs_kind : V.abs_kind) (can_end : bool) - (destructure_shared_values : bool) (ctx : C.eval_ctx) (abs0 : V.abs) : V.abs - = +let destructure_abs (abs_kind : abs_kind) (can_end : bool) + (destructure_shared_values : bool) (ctx : eval_ctx) (abs0 : abs) : abs = (* Accumulator to store the destructured values *) let avalues = ref [] in (* Utility function to store a value in the accumulator *) @@ -1635,8 +1619,8 @@ let destructure_abs (abs_kind : V.abs_kind) (can_end : bool) *) let push_fail _ = raise (Failure "Unreachable") in (* Function to explore an avalue and destructure it *) - let rec list_avalues (allow_borrows : bool) (push : V.typed_avalue -> unit) - (av : V.typed_avalue) : unit = + let rec list_avalues (allow_borrows : bool) (push : typed_avalue -> unit) + (av : typed_avalue) : unit = let ty = av.ty in match av.value with | ABottom | AIgnored -> () @@ -1655,7 +1639,7 @@ let destructure_abs (abs_kind : V.abs_kind) (can_end : bool) in (* Push a value *) let ignored = mk_aignored child_av.ty in - let value = V.ALoan (ASharedLoan (bids, sv, ignored)) in + let value = ALoan (ASharedLoan (bids, sv, ignored)) in push { value; ty }; (* Explore the child *) list_avalues false push_fail child_av; @@ -1671,7 +1655,7 @@ let destructure_abs (abs_kind : V.abs_kind) (can_end : bool) list_avalues false push_fail child_av; (* Explore the whole loan *) let ignored = mk_aignored child_av.ty in - let value = V.ALoan (AMutLoan (bid, ignored)) in + let value = ALoan (AMutLoan (bid, ignored)) in push { value; ty } | AIgnoredMutLoan (opt_bid, child_av) -> (* We don't support nested borrows for now *) @@ -1699,7 +1683,7 @@ let destructure_abs (abs_kind : V.abs_kind) (can_end : bool) list_avalues false push_fail child_av; (* Explore the borrow *) let ignored = mk_aignored child_av.ty in - let value = V.ABorrow (AMutBorrow (bid, ignored)) in + let value = ABorrow (AMutBorrow (bid, ignored)) in push { value; ty } | ASharedBorrow _ -> (* Nothing specific to do: keep the value as it is *) @@ -1731,7 +1715,7 @@ let destructure_abs (abs_kind : V.abs_kind) (can_end : bool) (* For now, we fore all symbolic values containing borrows to be eagerly expanded *) assert (not (ty_has_borrows ctx.type_context.type_infos ty)) - and list_values (v : V.typed_value) : V.typed_avalue list * V.typed_value = + and list_values (v : typed_value) : typed_avalue list * typed_value = let ty = v.ty in match v.value with | VLiteral _ -> ([], v) @@ -1753,24 +1737,23 @@ let destructure_abs (abs_kind : V.abs_kind) (can_end : bool) if destructure_shared_values then ( (* Rem.: the shared value can't contain loans nor borrows *) assert (ty_no_regions ty); - let av : V.typed_avalue = + let av : typed_avalue = assert (not (value_has_loans_or_borrows ctx sv.value)); (* We introduce fresh ids for the symbolic values *) - let mk_value_with_fresh_sids (v : V.typed_value) : V.typed_value - = + let mk_value_with_fresh_sids (v : typed_value) : typed_value = let visitor = object - inherit [_] V.map_typed_avalue + inherit [_] map_typed_avalue method! visit_symbolic_value_id _ _ = - C.fresh_symbolic_value_id () + fresh_symbolic_value_id () end in visitor#visit_typed_value () v in let sv = mk_value_with_fresh_sids sv in (* Create the new avalue *) - let value = V.ALoan (ASharedLoan (bids, sv, mk_aignored ty)) in + let value = ALoan (ASharedLoan (bids, sv, mk_aignored ty)) in { value; ty } in let avl = List.append [ av ] avl in @@ -1790,32 +1773,32 @@ let destructure_abs (abs_kind : V.abs_kind) (can_end : bool) (* Update *) { abs0 with avalues; kind = abs_kind; can_end } -let abs_is_destructured (destructure_shared_values : bool) (ctx : C.eval_ctx) - (abs : V.abs) : bool = +let abs_is_destructured (destructure_shared_values : bool) (ctx : eval_ctx) + (abs : abs) : bool = let abs' = destructure_abs abs.kind abs.can_end destructure_shared_values ctx abs in abs = abs' -let convert_value_to_abstractions (abs_kind : V.abs_kind) (can_end : bool) - (destructure_shared_values : bool) (ctx : C.eval_ctx) (v : V.typed_value) : - V.abs list = +let convert_value_to_abstractions (abs_kind : abs_kind) (can_end : bool) + (destructure_shared_values : bool) (ctx : eval_ctx) (v : typed_value) : + abs list = (* Convert the value to a list of avalues *) let absl = ref [] in - let push_abs (r_id : T.RegionId.id) (avalues : V.typed_avalue list) : unit = + let push_abs (r_id : RegionId.id) (avalues : typed_avalue list) : unit = if avalues = [] then () else (* Create the abs - note that we keep the order of the avalues as it is (unlike the environments) *) let abs = { - V.abs_id = C.fresh_abstraction_id (); + abs_id = fresh_abstraction_id (); kind = abs_kind; can_end; - parents = V.AbstractionId.Set.empty; + parents = AbstractionId.Set.empty; original_parents = []; - regions = T.RegionId.Set.singleton r_id; - ancestors_regions = T.RegionId.Set.empty; + regions = RegionId.Set.singleton r_id; + ancestors_regions = RegionId.Set.empty; avalues; } in @@ -1830,8 +1813,8 @@ let convert_value_to_abstractions (abs_kind : V.abs_kind) (can_end : bool) is [true], this shared value will be stripped of its shared loans. *) let rec to_avalues (allow_borrows : bool) (inside_borrowed : bool) - (group : bool) (r_id : T.RegionId.id) (v : V.typed_value) : - V.typed_avalue list * V.typed_value = + (group : bool) (r_id : RegionId.id) (v : typed_value) : + typed_avalue list * typed_value = (* Debug *) log#ldebug (lazy @@ -1863,7 +1846,7 @@ let convert_value_to_abstractions (abs_kind : V.abs_kind) (can_end : bool) let field_values = List.map (fun fv -> - let r_id = C.fresh_region_id () in + let r_id = fresh_region_id () in let avl, fv = to_avalues allow_borrows inside_borrowed group r_id fv in @@ -1887,18 +1870,18 @@ let convert_value_to_abstractions (abs_kind : V.abs_kind) (can_end : bool) match bc with | VSharedBorrow bid -> assert (ty_no_regions ref_ty); - let ty = T.TRef (RVar r_id, ref_ty, kind) in - let value = V.ABorrow (ASharedBorrow bid) in - ([ { V.value; ty } ], v) + let ty = TRef (RVar r_id, ref_ty, kind) in + let value = ABorrow (ASharedBorrow bid) in + ([ { value; ty } ], v) | VMutBorrow (bid, bv) -> - let r_id = if group then r_id else C.fresh_region_id () in + let r_id = if group then r_id else fresh_region_id () in (* We don't support nested borrows for now *) assert (not (value_has_borrows ctx bv.value)); (* Create an avalue to push - note that we use [AIgnore] for the inner avalue *) - let ty = T.TRef (RVar r_id, ref_ty, kind) in + let ty = TRef (RVar r_id, ref_ty, kind) in let ignored = mk_aignored ref_ty in - let av = V.ABorrow (AMutBorrow (bid, ignored)) in - let av = { V.value = av; ty } in + let av = ABorrow (AMutBorrow (bid, ignored)) in + let av = { value = av; ty } in (* Continue exploring, looking for loans (and forbidding borrows, because we don't support nested borrows for now) *) let avl, bv = to_avalues false true true r_id bv in @@ -1910,21 +1893,21 @@ let convert_value_to_abstractions (abs_kind : V.abs_kind) (can_end : bool) | VLoan lc -> ( match lc with | VSharedLoan (bids, sv) -> - let r_id = if group then r_id else C.fresh_region_id () in + let r_id = if group then r_id else fresh_region_id () in (* We don't support nested borrows for now *) assert (not (value_has_borrows ctx sv.value)); (* Push the avalue - note that we use [AIgnore] for the inner avalue *) (* For avalues, a loan has the borrow type *) assert (ty_no_regions ty); - let ty = mk_ref_ty (RVar r_id) ty Shared in + let ty = mk_ref_ty (RVar r_id) ty RShared in let ignored = mk_aignored ty in (* Rem.: the shared value might contain loans *) let avl, sv = to_avalues false true true r_id sv in - let av = V.ALoan (ASharedLoan (bids, sv, ignored)) in - let av = { V.value = av; ty } in + let av = ALoan (ASharedLoan (bids, sv, ignored)) in + let av = { value = av; ty } in (* Continue exploring, looking for loans (and forbidding borrows, because we don't support nested borrows for now) *) - let value : V.value = + let value : value = if destructure_shared_values then sv.value else VLoan (VSharedLoan (bids, sv)) in @@ -1934,10 +1917,10 @@ let convert_value_to_abstractions (abs_kind : V.abs_kind) (can_end : bool) (* Push the avalue - note that we use [AIgnore] for the inner avalue *) (* For avalues, a loan has the borrow type *) assert (ty_no_regions ty); - let ty = mk_ref_ty (RVar r_id) ty Mut in + let ty = mk_ref_ty (RVar r_id) ty RMut in let ignored = mk_aignored ty in - let av = V.ALoan (AMutLoan (bid, ignored)) in - let av = { V.value = av; ty } in + let av = ALoan (AMutLoan (bid, ignored)) in + let av = { value = av; ty } in ([ av ], v)) | VSymbolic _ -> (* For now, we force all the symbolic values containing borrows to @@ -1947,28 +1930,28 @@ let convert_value_to_abstractions (abs_kind : V.abs_kind) (can_end : bool) ([], v) in (* Generate the avalues *) - let r_id = C.fresh_region_id () in + let r_id = fresh_region_id () in let values, _ = to_avalues true false false r_id v in (* Introduce an abstraction for the returned values *) push_abs r_id values; (* Return *) List.rev !absl -type borrow_or_loan_id = BorrowId of V.borrow_id | LoanId of V.loan_id +type borrow_or_loan_id = BorrowId of borrow_id | LoanId of loan_id type g_loan_content_with_ty = - (T.ety * V.loan_content, T.rty * V.aloan_content) concrete_or_abs + (ety * loan_content, rty * aloan_content) concrete_or_abs type g_borrow_content_with_ty = - (T.ety * V.borrow_content, T.rty * V.aborrow_content) concrete_or_abs + (ety * borrow_content, rty * aborrow_content) concrete_or_abs type merge_abstraction_info = { - loans : V.loan_id_set; - borrows : V.borrow_id_set; + loans : loan_id_set; + borrows : borrow_id_set; borrows_loans : borrow_or_loan_id list; (** We use a list to preserve the order in which the borrows were found *) - loan_to_content : g_loan_content_with_ty V.BorrowId.Map.t; - borrow_to_content : g_borrow_content_with_ty V.BorrowId.Map.t; + loan_to_content : g_loan_content_with_ty BorrowId.Map.t; + borrow_to_content : g_borrow_content_with_ty BorrowId.Map.t; } (** Small utility to help merging abstractions. @@ -1983,54 +1966,54 @@ type merge_abstraction_info = { - all the borrows are destructured (for instance, shared loans can't contain shared loans). *) -let compute_merge_abstraction_info (ctx : C.eval_ctx) (abs : V.abs) : +let compute_merge_abstraction_info (ctx : eval_ctx) (abs : abs) : merge_abstraction_info = - let loans : V.loan_id_set ref = ref V.BorrowId.Set.empty in - let borrows : V.borrow_id_set ref = ref V.BorrowId.Set.empty in + let loans : loan_id_set ref = ref BorrowId.Set.empty in + let borrows : borrow_id_set ref = ref BorrowId.Set.empty in let borrows_loans : borrow_or_loan_id list ref = ref [] in - let loan_to_content : g_loan_content_with_ty V.BorrowId.Map.t ref = - ref V.BorrowId.Map.empty + let loan_to_content : g_loan_content_with_ty BorrowId.Map.t ref = + ref BorrowId.Map.empty in - let borrow_to_content : g_borrow_content_with_ty V.BorrowId.Map.t ref = - ref V.BorrowId.Map.empty + let borrow_to_content : g_borrow_content_with_ty BorrowId.Map.t ref = + ref BorrowId.Map.empty in let push_loans ids (lc : g_loan_content_with_ty) : unit = - assert (V.BorrowId.Set.disjoint !loans ids); - loans := V.BorrowId.Set.union !loans ids; - V.BorrowId.Set.iter + assert (BorrowId.Set.disjoint !loans ids); + loans := BorrowId.Set.union !loans ids; + BorrowId.Set.iter (fun id -> - assert (not (V.BorrowId.Map.mem id !loan_to_content)); - loan_to_content := V.BorrowId.Map.add id lc !loan_to_content; + assert (not (BorrowId.Map.mem id !loan_to_content)); + loan_to_content := BorrowId.Map.add id lc !loan_to_content; borrows_loans := LoanId id :: !borrows_loans) ids in let push_loan id (lc : g_loan_content_with_ty) : unit = - assert (not (V.BorrowId.Set.mem id !loans)); - loans := V.BorrowId.Set.add id !loans; - assert (not (V.BorrowId.Map.mem id !loan_to_content)); - loan_to_content := V.BorrowId.Map.add id lc !loan_to_content; + assert (not (BorrowId.Set.mem id !loans)); + loans := BorrowId.Set.add id !loans; + assert (not (BorrowId.Map.mem id !loan_to_content)); + loan_to_content := BorrowId.Map.add id lc !loan_to_content; borrows_loans := LoanId id :: !borrows_loans in let push_borrow id (bc : g_borrow_content_with_ty) : unit = - assert (not (V.BorrowId.Set.mem id !borrows)); - borrows := V.BorrowId.Set.add id !borrows; - assert (not (V.BorrowId.Map.mem id !borrow_to_content)); - borrow_to_content := V.BorrowId.Map.add id bc !borrow_to_content; + assert (not (BorrowId.Set.mem id !borrows)); + borrows := BorrowId.Set.add id !borrows; + assert (not (BorrowId.Map.mem id !borrow_to_content)); + borrow_to_content := BorrowId.Map.add id bc !borrow_to_content; borrows_loans := BorrowId id :: !borrows_loans in let iter_avalues = object - inherit [_] V.iter_typed_avalue as super + inherit [_] iter_typed_avalue as super (** We redefine this to track the types *) method! visit_typed_avalue _ v = - super#visit_typed_avalue (Some (Abstract v.V.ty)) v + super#visit_typed_avalue (Some (Abstract v.ty)) v (** We redefine this to track the types *) - method! visit_typed_value _ (v : V.typed_value) = - super#visit_typed_value (Some (Concrete v.V.ty)) v + method! visit_typed_value _ (v : typed_value) = + super#visit_typed_value (Some (Concrete v.ty)) v method! visit_loan_content env lc = (* Can happen if we explore shared values whose sub-values are @@ -2059,10 +2042,10 @@ let compute_merge_abstraction_info (ctx : C.eval_ctx) (abs : V.abs) : in (* Register the loans *) (match lc with - | V.ASharedLoan (bids, _, _) -> push_loans bids (Abstract (ty, lc)) - | V.AMutLoan (bid, _) -> push_loan bid (Abstract (ty, lc)) - | V.AEndedMutLoan _ | V.AEndedSharedLoan _ | V.AIgnoredMutLoan _ - | V.AEndedIgnoredMutLoan _ | V.AIgnoredSharedLoan _ -> + | ASharedLoan (bids, _, _) -> push_loans bids (Abstract (ty, lc)) + | AMutLoan (bid, _) -> push_loan bid (Abstract (ty, lc)) + | AEndedMutLoan _ | AEndedSharedLoan _ | AIgnoredMutLoan _ + | AEndedIgnoredMutLoan _ | AIgnoredSharedLoan _ -> (* The abstraction has been destructured, so those shouldn't appear *) raise (Failure "Unreachable")); (* Continue *) @@ -2076,20 +2059,20 @@ let compute_merge_abstraction_info (ctx : C.eval_ctx) (abs : V.abs) : in (* Explore the borrow content *) (match bc with - | V.AMutBorrow (bid, _) -> push_borrow bid (Abstract (ty, bc)) - | V.ASharedBorrow bid -> push_borrow bid (Abstract (ty, bc)) - | V.AProjSharedBorrow asb -> + | AMutBorrow (bid, _) -> push_borrow bid (Abstract (ty, bc)) + | ASharedBorrow bid -> push_borrow bid (Abstract (ty, bc)) + | AProjSharedBorrow asb -> let register asb = match asb with - | V.AsbBorrow bid -> push_borrow bid (Abstract (ty, bc)) - | V.AsbProjReborrows _ -> + | AsbBorrow bid -> push_borrow bid (Abstract (ty, bc)) + | AsbProjReborrows _ -> (* Can only happen if the symbolic value (potentially) contains borrows - i.e., we have nested borrows *) raise (Failure "Unreachable") in List.iter register asb - | V.AIgnoredMutBorrow _ | V.AEndedIgnoredMutBorrow _ - | V.AEndedMutBorrow _ | V.AEndedSharedBorrow -> + | AIgnoredMutBorrow _ | AEndedIgnoredMutBorrow _ | AEndedMutBorrow _ + | AEndedSharedBorrow -> (* The abstraction has been destructured, so those shouldn't appear *) raise (Failure "Unreachable")); super#visit_aborrow_content env bc @@ -2100,7 +2083,7 @@ let compute_merge_abstraction_info (ctx : C.eval_ctx) (abs : V.abs) : end in - List.iter (iter_avalues#visit_typed_avalue None) abs.V.avalues; + List.iter (iter_avalues#visit_typed_avalue None) abs.avalues; { loans = !loans; @@ -2112,12 +2095,7 @@ let compute_merge_abstraction_info (ctx : C.eval_ctx) (abs : V.abs) : type merge_duplicates_funcs = { merge_amut_borrows : - V.borrow_id -> - T.rty -> - V.typed_avalue -> - T.rty -> - V.typed_avalue -> - V.typed_avalue; + borrow_id -> rty -> typed_avalue -> rty -> typed_avalue -> typed_avalue; (** Parameters: - [id] - [ty0] @@ -2127,19 +2105,14 @@ type merge_duplicates_funcs = { The children should be [AIgnored]. *) - merge_ashared_borrows : V.borrow_id -> T.rty -> T.rty -> V.typed_avalue; + merge_ashared_borrows : borrow_id -> rty -> rty -> typed_avalue; (** Parameters: - [id] - [ty0] - [ty1] *) merge_amut_loans : - V.loan_id -> - T.rty -> - V.typed_avalue -> - T.rty -> - V.typed_avalue -> - V.typed_avalue; + loan_id -> rty -> typed_avalue -> rty -> typed_avalue -> typed_avalue; (** Parameters: - [id] - [ty0] @@ -2150,14 +2123,14 @@ type merge_duplicates_funcs = { The children should be [AIgnored]. *) merge_ashared_loans : - V.loan_id_set -> - T.rty -> - V.typed_value -> - V.typed_avalue -> - T.rty -> - V.typed_value -> - V.typed_avalue -> - V.typed_avalue; + loan_id_set -> + rty -> + typed_value -> + typed_avalue -> + rty -> + typed_value -> + typed_avalue -> + typed_avalue; (** Parameters: - [ids] - [ty0] @@ -2173,9 +2146,9 @@ type merge_duplicates_funcs = { Merge two abstractions into one, without updating the context. *) -let merge_into_abstraction_aux (abs_kind : V.abs_kind) (can_end : bool) - (merge_funs : merge_duplicates_funcs option) (ctx : C.eval_ctx) - (abs0 : V.abs) (abs1 : V.abs) : V.abs = +let merge_into_abstraction_aux (abs_kind : abs_kind) (can_end : bool) + (merge_funs : merge_duplicates_funcs option) (ctx : eval_ctx) (abs0 : abs) + (abs1 : abs) : abs = log#ldebug (lazy ("merge_into_abstraction_aux:\n- abs0:\n" ^ abs_to_string ctx abs0 @@ -2211,8 +2184,8 @@ let merge_into_abstraction_aux (abs_kind : V.abs_kind) (can_end : bool) (* Sanity check: there is no loan/borrows which appears in both abstractions, unless we allow to merge duplicates *) if merge_funs = None then ( - assert (V.BorrowId.Set.disjoint borrows0 borrows1); - assert (V.BorrowId.Set.disjoint loans0 loans1)); + assert (BorrowId.Set.disjoint borrows0 borrows1); + assert (BorrowId.Set.disjoint loans0 loans1)); (* Merge. There are several cases: @@ -2232,8 +2205,8 @@ let merge_into_abstraction_aux (abs_kind : V.abs_kind) (can_end : bool) We ignore this case for now: we check that whenever we merge two shared loans, then their sets of ids are equal. *) - let merged_borrows = ref V.BorrowId.Set.empty in - let merged_loans = ref V.BorrowId.Set.empty in + let merged_borrows = ref BorrowId.Set.empty in + let merged_loans = ref BorrowId.Set.empty in let avalues = ref [] in let push_avalue av = log#ldebug @@ -2247,35 +2220,35 @@ let merge_into_abstraction_aux (abs_kind : V.abs_kind) (can_end : bool) in let intersect = - V.BorrowId.Set.union - (V.BorrowId.Set.inter loans0 borrows1) - (V.BorrowId.Set.inter loans1 borrows0) + BorrowId.Set.union + (BorrowId.Set.inter loans0 borrows1) + (BorrowId.Set.inter loans1 borrows0) in - let filter_bids (bids : V.BorrowId.Set.t) : V.BorrowId.Set.t = - let bids = V.BorrowId.Set.diff bids intersect in - assert (not (V.BorrowId.Set.is_empty bids)); + let filter_bids (bids : BorrowId.Set.t) : BorrowId.Set.t = + let bids = BorrowId.Set.diff bids intersect in + assert (not (BorrowId.Set.is_empty bids)); bids in - let filter_bid (bid : V.BorrowId.id) : V.BorrowId.id option = - if V.BorrowId.Set.mem bid intersect then None else Some bid + let filter_bid (bid : BorrowId.id) : BorrowId.id option = + if BorrowId.Set.mem bid intersect then None else Some bid in - let borrow_is_merged id = V.BorrowId.Set.mem id !merged_borrows in + let borrow_is_merged id = BorrowId.Set.mem id !merged_borrows in let set_borrow_as_merged id = - merged_borrows := V.BorrowId.Set.add id !merged_borrows + merged_borrows := BorrowId.Set.add id !merged_borrows in - let loan_is_merged id = V.BorrowId.Set.mem id !merged_loans in + let loan_is_merged id = BorrowId.Set.mem id !merged_loans in let set_loan_as_merged id = - merged_loans := V.BorrowId.Set.add id !merged_loans + merged_loans := BorrowId.Set.add id !merged_loans in - let set_loans_as_merged ids = V.BorrowId.Set.iter set_loan_as_merged ids in + let set_loans_as_merged ids = BorrowId.Set.iter set_loan_as_merged ids in (* Some utility functions *) (* Merge two aborrow contents - note that those contents must have the same id *) - let merge_aborrow_contents (ty0 : T.rty) (bc0 : V.aborrow_content) - (ty1 : T.rty) (bc1 : V.aborrow_content) : V.typed_avalue = + let merge_aborrow_contents (ty0 : rty) (bc0 : aborrow_content) (ty1 : rty) + (bc1 : aborrow_content) : typed_avalue = match (bc0, bc1) with - | V.AMutBorrow (id, child0), V.AMutBorrow (_, child1) -> + | AMutBorrow (id, child0), AMutBorrow (_, child1) -> (Option.get merge_funs).merge_amut_borrows id ty0 child0 ty1 child1 | ASharedBorrow id, ASharedBorrow _ -> (Option.get merge_funs).merge_ashared_borrows id ty0 ty1 @@ -2289,7 +2262,7 @@ let merge_into_abstraction_aux (abs_kind : V.abs_kind) (can_end : bool) in let merge_g_borrow_contents (bc0 : g_borrow_content_with_ty) - (bc1 : g_borrow_content_with_ty) : V.typed_avalue = + (bc1 : g_borrow_content_with_ty) : typed_avalue = match (bc0, bc1) with | Concrete _, Concrete _ -> (* This can happen only in case of nested borrows *) @@ -2301,10 +2274,10 @@ let merge_into_abstraction_aux (abs_kind : V.abs_kind) (can_end : bool) raise (Failure "Unreachable") in - let merge_aloan_contents (ty0 : T.rty) (lc0 : V.aloan_content) (ty1 : T.rty) - (lc1 : V.aloan_content) : V.typed_avalue option = + let merge_aloan_contents (ty0 : rty) (lc0 : aloan_content) (ty1 : rty) + (lc1 : aloan_content) : typed_avalue option = match (lc0, lc1) with - | V.AMutLoan (id, child0), V.AMutLoan (_, child1) -> + | AMutLoan (id, child0), AMutLoan (_, child1) -> (* Register the loan id *) set_loan_as_merged id; (* Merge *) @@ -2316,9 +2289,9 @@ let merge_into_abstraction_aux (abs_kind : V.abs_kind) (can_end : bool) (* Check that the sets of ids are the same - if it is not the case, it means we actually need to merge more than 2 avalues: we ignore this case for now *) - assert (V.BorrowId.Set.equal ids0 ids1); + assert (BorrowId.Set.equal ids0 ids1); let ids = ids0 in - if V.BorrowId.Set.is_empty ids then ( + if BorrowId.Set.is_empty ids then ( (* If the set of ids is empty, we can eliminate this shared loan. For now, we check that we can eliminate the whole shared value altogether. @@ -2328,10 +2301,10 @@ let merge_into_abstraction_aux (abs_kind : V.abs_kind) (can_end : bool) to preserve (in practice it works because we destructure the shared values in the abstractions, and forbid nested borrows). *) - assert (not (value_has_loans_or_borrows ctx sv0.V.value)); - assert (not (value_has_loans_or_borrows ctx sv0.V.value)); - assert (is_aignored child0.V.value); - assert (is_aignored child1.V.value); + assert (not (value_has_loans_or_borrows ctx sv0.value)); + assert (not (value_has_loans_or_borrows ctx sv0.value)); + assert (is_aignored child0.value); + assert (is_aignored child1.value); None) else ( (* Register the loan ids *) @@ -2350,7 +2323,7 @@ let merge_into_abstraction_aux (abs_kind : V.abs_kind) (can_end : bool) to register the merged loan ids: the caller doesn't do it (contrary to the borrow case) *) let merge_g_loan_contents (lc0 : g_loan_content_with_ty) - (lc1 : g_loan_content_with_ty) : V.typed_avalue option = + (lc1 : g_loan_content_with_ty) : typed_avalue option = match (lc0, lc1) with | Concrete _, Concrete _ -> (* This can not happen: the values should have been destructured *) @@ -2374,7 +2347,7 @@ let merge_into_abstraction_aux (abs_kind : V.abs_kind) (can_end : bool) log#ldebug (lazy ("merge_into_abstraction_aux: merging borrow " - ^ V.BorrowId.to_string bid)); + ^ BorrowId.to_string bid)); (* Check if the borrow has already been merged - this can happen because we go through all the borrows/loans in [abs0] *then* @@ -2388,10 +2361,10 @@ let merge_into_abstraction_aux (abs_kind : V.abs_kind) (can_end : bool) | None -> () | Some bid -> (* Lookup the contents *) - let bc0 = V.BorrowId.Map.find_opt bid borrow_to_content0 in - let bc1 = V.BorrowId.Map.find_opt bid borrow_to_content1 in + let bc0 = BorrowId.Map.find_opt bid borrow_to_content0 in + let bc1 = BorrowId.Map.find_opt bid borrow_to_content1 in (* Merge *) - let av : V.typed_avalue = + let av : typed_avalue = match (bc0, bc1) with | None, Some bc | Some bc, None -> ( match bc with @@ -2401,7 +2374,7 @@ let merge_into_abstraction_aux (abs_kind : V.abs_kind) (can_end : bool) loan *) raise (Failure "Unreachable") - | Abstract (ty, bc) -> { V.value = V.ABorrow bc; ty }) + | Abstract (ty, bc) -> { value = ABorrow bc; ty }) | Some bc0, Some bc1 -> assert (merge_funs <> None); merge_g_borrow_contents bc0 bc1 @@ -2421,17 +2394,17 @@ let merge_into_abstraction_aux (abs_kind : V.abs_kind) (can_end : bool) log#ldebug (lazy ("merge_into_abstraction_aux: merging loan " - ^ V.BorrowId.to_string bid)); + ^ BorrowId.to_string bid)); (* Check if we need to filter it *) match filter_bid bid with | None -> () | Some bid -> (* Lookup the contents *) - let lc0 = V.BorrowId.Map.find_opt bid loan_to_content0 in - let lc1 = V.BorrowId.Map.find_opt bid loan_to_content1 in + let lc0 = BorrowId.Map.find_opt bid loan_to_content0 in + let lc1 = BorrowId.Map.find_opt bid loan_to_content1 in (* Merge *) - let av : V.typed_avalue option = + let av : typed_avalue option = match (lc0, lc1) with | None, Some lc | Some lc, None -> ( match lc with @@ -2441,21 +2414,21 @@ let merge_into_abstraction_aux (abs_kind : V.abs_kind) (can_end : bool) raise (Failure "Unreachable") | Abstract (ty, lc) -> ( match lc with - | V.ASharedLoan (bids, sv, child) -> + | ASharedLoan (bids, sv, child) -> let bids = filter_bids bids in - assert (not (V.BorrowId.Set.is_empty bids)); - assert (is_aignored child.V.value); + assert (not (BorrowId.Set.is_empty bids)); + assert (is_aignored child.value); assert ( - not (value_has_loans_or_borrows ctx sv.V.value)); - let lc = V.ASharedLoan (bids, sv, child) in + not (value_has_loans_or_borrows ctx sv.value)); + let lc = ASharedLoan (bids, sv, child) in set_loans_as_merged bids; - Some { V.value = V.ALoan lc; ty } - | V.AMutLoan _ -> + Some { value = ALoan lc; ty } + | AMutLoan _ -> set_loan_as_merged bid; - Some { V.value = V.ALoan lc; ty } - | V.AEndedMutLoan _ | V.AEndedSharedLoan _ - | V.AIgnoredMutLoan _ | V.AEndedIgnoredMutLoan _ - | V.AIgnoredSharedLoan _ -> + Some { value = ALoan lc; ty } + | AEndedMutLoan _ | AEndedSharedLoan _ + | AIgnoredMutLoan _ | AEndedIgnoredMutLoan _ + | AIgnoredSharedLoan _ -> (* The abstraction has been destructured, so those shouldn't appear *) raise (Failure "Unreachable"))) | Some lc0, Some lc1 -> @@ -2475,8 +2448,8 @@ let merge_into_abstraction_aux (abs_kind : V.abs_kind) (can_end : bool) meaning it is easier to find fixed points). *) let avalues = - let is_borrow (av : V.typed_avalue) : bool = - match av.V.value with + let is_borrow (av : typed_avalue) : bool = + match av.value with | ABorrow _ -> true | ALoan _ -> false | _ -> raise (Failure "Unexpected") @@ -2488,21 +2461,21 @@ let merge_into_abstraction_aux (abs_kind : V.abs_kind) (can_end : bool) (* Filter the regions *) (* Create the new abstraction *) - let abs_id = C.fresh_abstraction_id () in + let abs_id = fresh_abstraction_id () in (* Note that one of the two abstractions might a parent of the other *) let parents = - V.AbstractionId.Set.diff - (V.AbstractionId.Set.union abs0.parents abs1.parents) - (V.AbstractionId.Set.of_list [ abs0.abs_id; abs1.abs_id ]) + AbstractionId.Set.diff + (AbstractionId.Set.union abs0.parents abs1.parents) + (AbstractionId.Set.of_list [ abs0.abs_id; abs1.abs_id ]) in - let original_parents = V.AbstractionId.Set.elements parents in - let regions = T.RegionId.Set.union abs0.regions abs1.regions in + let original_parents = AbstractionId.Set.elements parents in + let regions = RegionId.Set.union abs0.regions abs1.regions in let ancestors_regions = - T.RegionId.Set.diff (T.RegionId.Set.union abs0.regions abs1.regions) regions + RegionId.Set.diff (RegionId.Set.union abs0.regions abs1.regions) regions in let abs = { - V.abs_id; + abs_id; kind = abs_kind; can_end; parents; @@ -2519,19 +2492,19 @@ let merge_into_abstraction_aux (abs_kind : V.abs_kind) (can_end : bool) abs (** Merge the regions in a context to a single region *) -let ctx_merge_regions (ctx : C.eval_ctx) (rid : T.RegionId.id) - (rids : T.RegionId.Set.t) : C.eval_ctx = - let rsubst x = if T.RegionId.Set.mem x rids then rid else x in +let ctx_merge_regions (ctx : eval_ctx) (rid : RegionId.id) + (rids : RegionId.Set.t) : eval_ctx = + let rsubst x = if RegionId.Set.mem x rids then rid else x in let env = Substitute.env_subst_rids rsubst ctx.env in - { ctx with C.env } + { ctx with env } -let merge_into_abstraction (abs_kind : V.abs_kind) (can_end : bool) - (merge_funs : merge_duplicates_funcs option) (ctx : C.eval_ctx) - (abs_id0 : V.AbstractionId.id) (abs_id1 : V.AbstractionId.id) : - C.eval_ctx * V.AbstractionId.id = +let merge_into_abstraction (abs_kind : abs_kind) (can_end : bool) + (merge_funs : merge_duplicates_funcs option) (ctx : eval_ctx) + (abs_id0 : AbstractionId.id) (abs_id1 : AbstractionId.id) : + eval_ctx * AbstractionId.id = (* Lookup the abstractions *) - let abs0 = C.ctx_lookup_abs ctx abs_id0 in - let abs1 = C.ctx_lookup_abs ctx abs_id1 in + let abs0 = ctx_lookup_abs ctx abs_id0 in + let abs1 = ctx_lookup_abs ctx abs_id1 in (* Merge them *) let nabs = @@ -2540,8 +2513,8 @@ let merge_into_abstraction (abs_kind : V.abs_kind) (can_end : bool) (* Update the environment: replace the abstraction 1 with the result of the merge, remove the abstraction 0 *) - let ctx = fst (C.ctx_subst_abs ctx abs_id1 nabs) in - let ctx = fst (C.ctx_remove_abs ctx abs_id0) in + let ctx = fst (ctx_subst_abs ctx abs_id1 nabs) in + let ctx = fst (ctx_remove_abs ctx abs_id0) in (* Merge all the regions from the abstraction into one (the first - i.e., the one with the smallest id). Note that we need to do this in the whole @@ -2552,11 +2525,11 @@ let merge_into_abstraction (abs_kind : V.abs_kind) (can_end : bool) let ctx = let regions = nabs.regions in (* Pick the first region id (this is the smallest) *) - let rid = T.RegionId.Set.min_elt regions in + let rid = RegionId.Set.min_elt regions in (* If there is only one region, do nothing *) - if T.RegionId.Set.cardinal regions = 1 then ctx + if RegionId.Set.cardinal regions = 1 then ctx else - let rids = T.RegionId.Set.remove rid regions in + let rids = RegionId.Set.remove rid regions in ctx_merge_regions ctx rid rids in diff --git a/compiler/InterpreterBorrows.mli b/compiler/InterpreterBorrows.mli index 6302dcc3..e47ba82d 100644 --- a/compiler/InterpreterBorrows.mli +++ b/compiler/InterpreterBorrows.mli @@ -1,49 +1,44 @@ -module T = Types -module V = Values -module C = Contexts -module Subst = Substitute -module L = Logging -module S = SynthesizeSymbolic +open Types +open Values +open Contexts open Cps -open InterpreterProjectors (** When copying values, we duplicate the shared borrows. This is tantamount to reborrowing the shared value. The [reborrow_shared original_id new_bid ctx] applies this change to an environment [ctx] by inserting a new borrow id in the set of borrows tracked by a shared value, referenced by the [original_bid] argument. *) -val reborrow_shared : V.BorrowId.id -> V.BorrowId.id -> C.eval_ctx -> C.eval_ctx +val reborrow_shared : BorrowId.id -> BorrowId.id -> eval_ctx -> eval_ctx (** End a borrow identified by its id, while preserving the invariants. If the borrow is inside another borrow/an abstraction or contains loans, [end_borrow] will end those borrows/abstractions/loans first. *) -val end_borrow : C.config -> V.BorrowId.id -> cm_fun +val end_borrow : config -> BorrowId.id -> cm_fun (** End a set of borrows identified by their ids, while preserving the invariants. *) -val end_borrows : C.config -> V.BorrowId.Set.t -> cm_fun +val end_borrows : config -> BorrowId.Set.t -> cm_fun (** End an abstraction while preserving the invariants. *) -val end_abstraction : C.config -> V.AbstractionId.id -> cm_fun +val end_abstraction : config -> AbstractionId.id -> cm_fun (** End a set of abstractions while preserving the invariants. *) -val end_abstractions : C.config -> V.AbstractionId.Set.t -> cm_fun +val end_abstractions : config -> AbstractionId.Set.t -> cm_fun (** End a borrow and return the resulting environment, ignoring synthesis *) -val end_borrow_no_synth : C.config -> V.BorrowId.id -> C.eval_ctx -> C.eval_ctx +val end_borrow_no_synth : config -> BorrowId.id -> eval_ctx -> eval_ctx (** End a set of borrows and return the resulting environment, ignoring synthesis *) -val end_borrows_no_synth : - C.config -> V.BorrowId.Set.t -> C.eval_ctx -> C.eval_ctx +val end_borrows_no_synth : config -> BorrowId.Set.t -> eval_ctx -> eval_ctx (** End an abstraction and return the resulting environment, ignoring synthesis *) val end_abstraction_no_synth : - C.config -> V.AbstractionId.id -> C.eval_ctx -> C.eval_ctx + config -> AbstractionId.id -> eval_ctx -> eval_ctx (** End a set of abstractions and return the resulting environment, ignoring synthesis *) val end_abstractions_no_synth : - C.config -> V.AbstractionId.Set.t -> C.eval_ctx -> C.eval_ctx + config -> AbstractionId.Set.t -> eval_ctx -> eval_ctx (** Promote a reserved mut borrow to a mut borrow, while preserving the invariants. @@ -54,7 +49,7 @@ val end_abstractions_no_synth : the corresponding shared loan with a mutable loan (after having ended the other shared borrows which point to this loan). *) -val promote_reserved_mut_borrow : C.config -> V.BorrowId.id -> cm_fun +val promote_reserved_mut_borrow : config -> BorrowId.id -> cm_fun (** Transform an abstraction to an abstraction where the values are not structured. @@ -96,7 +91,7 @@ val promote_reserved_mut_borrow : C.config -> V.BorrowId.id -> cm_fun - [ctx] - [abs] *) -val destructure_abs : V.abs_kind -> bool -> bool -> C.eval_ctx -> V.abs -> V.abs +val destructure_abs : abs_kind -> bool -> bool -> eval_ctx -> abs -> abs (** Return [true] if the values in an abstraction are destructured. @@ -104,7 +99,7 @@ val destructure_abs : V.abs_kind -> bool -> bool -> C.eval_ctx -> V.abs -> V.abs The input boolean is [destructure_shared_value]. See {!destructure_abs}. *) -val abs_is_destructured : bool -> C.eval_ctx -> V.abs -> bool +val abs_is_destructured : bool -> eval_ctx -> abs -> bool (** Turn a value into a abstractions. @@ -130,7 +125,7 @@ val abs_is_destructured : bool -> C.eval_ctx -> V.abs -> bool - [v] *) val convert_value_to_abstractions : - V.abs_kind -> bool -> bool -> C.eval_ctx -> V.typed_value -> V.abs list + abs_kind -> bool -> bool -> eval_ctx -> typed_value -> abs list (** See {!merge_into_abstraction}. @@ -139,12 +134,7 @@ val convert_value_to_abstractions : *) type merge_duplicates_funcs = { merge_amut_borrows : - V.borrow_id -> - T.rty -> - V.typed_avalue -> - T.rty -> - V.typed_avalue -> - V.typed_avalue; + borrow_id -> rty -> typed_avalue -> rty -> typed_avalue -> typed_avalue; (** Parameters: - [id] - [ty0] @@ -154,19 +144,14 @@ type merge_duplicates_funcs = { The children should be [AIgnored]. *) - merge_ashared_borrows : V.borrow_id -> T.rty -> T.rty -> V.typed_avalue; + merge_ashared_borrows : borrow_id -> rty -> rty -> typed_avalue; (** Parameters: - [id] - [ty0] - [ty1] *) merge_amut_loans : - V.loan_id -> - T.rty -> - V.typed_avalue -> - T.rty -> - V.typed_avalue -> - V.typed_avalue; + loan_id -> rty -> typed_avalue -> rty -> typed_avalue -> typed_avalue; (** Parameters: - [id] - [ty0] @@ -177,14 +162,14 @@ type merge_duplicates_funcs = { The children should be [AIgnored]. *) merge_ashared_loans : - V.loan_id_set -> - T.rty -> - V.typed_value -> - V.typed_avalue -> - T.rty -> - V.typed_value -> - V.typed_avalue -> - V.typed_avalue; + loan_id_set -> + rty -> + typed_value -> + typed_avalue -> + rty -> + typed_value -> + typed_avalue -> + typed_avalue; (** Parameters: - [ids] - [ty0] @@ -247,10 +232,10 @@ type merge_duplicates_funcs = { results from the merge. *) val merge_into_abstraction : - V.abs_kind -> + abs_kind -> bool -> merge_duplicates_funcs option -> - C.eval_ctx -> - V.AbstractionId.id -> - V.AbstractionId.id -> - C.eval_ctx * V.AbstractionId.id + eval_ctx -> + AbstractionId.id -> + AbstractionId.id -> + eval_ctx * AbstractionId.id diff --git a/compiler/InterpreterBorrowsCore.ml b/compiler/InterpreterBorrowsCore.ml index cde39e9b..b13d545c 100644 --- a/compiler/InterpreterBorrowsCore.ml +++ b/compiler/InterpreterBorrowsCore.ml @@ -3,17 +3,15 @@ also in Invariants or InterpreterProjectors *) -module T = Types -module V = Values -module C = Contexts -module Subst = Substitute -module L = Logging +open Types +open Values +open Contexts open Utils open TypesUtils open InterpreterUtils (** The local logger *) -let log = L.borrows_log +let log = Logging.borrows_log (** TODO: cleanup this a bit, once we have a better understanding about what we need. @@ -33,19 +31,19 @@ type exploration_kind = { 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 +type borrow_ids = Borrows of BorrowId.Set.t | Borrow of BorrowId.id [@@deriving show] type borrow_ids_or_symbolic_value = | BorrowIds of borrow_ids - | SymbolicValue of V.symbolic_value + | SymbolicValue of symbolic_value [@@deriving show] exception FoundBorrowIds of borrow_ids type priority_borrows_or_abs = | OuterBorrows of borrow_ids - | OuterAbs of V.AbstractionId.id + | OuterAbs of AbstractionId.id | InnerLoans of borrow_ids [@@deriving show] @@ -55,20 +53,17 @@ let update_if_none opt x = match opt with None -> Some x | _ -> opt exception FoundPriority of priority_borrows_or_abs type loan_or_borrow_content = - | LoanContent of V.loan_content - | BorrowContent of V.borrow_content + | LoanContent of loan_content + | BorrowContent of borrow_content [@@deriving show] -type borrow_or_abs_id = - | BorrowId of V.BorrowId.id - | AbsId of V.AbstractionId.id - +type borrow_or_abs_id = BorrowId of BorrowId.id | AbsId of 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 + | AbsId id -> "abs@" ^ AbstractionId.to_string id + | BorrowId id -> "l@" ^ BorrowId.to_string id let borrow_or_abs_ids_chain_to_string (ids : borrow_or_abs_ids) : string = let ids = List.rev ids in @@ -100,8 +95,8 @@ let add_borrow_or_abs_id_to_chain (msg : string) (id : borrow_or_abs_id) TODO: rename *) let rec compare_rtys (default : bool) (combine : bool -> bool -> bool) - (compare_regions : T.region -> T.region -> bool) (ty1 : T.rty) (ty2 : T.rty) - : bool = + (compare_regions : region -> region -> bool) (ty1 : rty) (ty2 : rty) : bool + = let compare = compare_rtys default combine compare_regions in (* Sanity check - TODO: don't do this at every recursive call *) assert (ty_is_rty ty1 && ty_is_rty ty2); @@ -166,8 +161,8 @@ let rec compare_rtys (default : bool) (combine : bool -> bool -> bool) | _ -> log#lerror (lazy - ("compare_rtys: unexpected inputs:" ^ "\n- ty1: " ^ T.show_ty ty1 - ^ "\n- ty2: " ^ T.show_ty ty2)); + ("compare_rtys: unexpected inputs:" ^ "\n- ty1: " ^ show_ty ty1 + ^ "\n- ty2: " ^ show_ty ty2)); raise (Failure "Unreachable") (** Check if two different projections intersect. This is necessary when @@ -177,8 +172,8 @@ let rec compare_rtys (default : bool) (combine : bool -> bool -> bool) 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 projections_intersect (ty1 : rty) (rset1 : RegionId.Set.t) (ty2 : rty) + (rset2 : RegionId.Set.t) : bool = let default = false in let combine b1 b2 = b1 || b2 in let compare_regions r1 r2 = @@ -192,8 +187,8 @@ let projections_intersect (ty1 : T.rty) (rset1 : T.RegionId.Set.t) (ty2 : T.rty) The regions in the types shouldn't be erased (this function will raise an exception otherwise). *) -let projection_contains (ty1 : T.rty) (rset1 : T.RegionId.Set.t) (ty2 : T.rty) - (rset2 : T.RegionId.Set.t) : bool = +let projection_contains (ty1 : rty) (rset1 : RegionId.Set.t) (ty2 : rty) + (rset2 : RegionId.Set.t) : bool = let default = true in let combine b1 b2 = b1 && b2 in let compare_regions r1 r2 = @@ -209,8 +204,8 @@ let projection_contains (ty1 : T.rty) (rset1 : T.RegionId.Set.t) (ty2 : T.rty) the {!InterpreterUtils.abs_or_var_id} is not necessarily {!constructor:Aeneas.InterpreterUtils.abs_or_var_id.VarId} or {!constructor:Aeneas.InterpreterUtils.abs_or_var_id.DummyVarId}: there can be concrete loans in abstractions (in the shared values). *) -let lookup_loan_opt (ek : exploration_kind) (l : V.BorrowId.id) - (ctx : C.eval_ctx) : (abs_or_var_id * g_loan_content) option = +let lookup_loan_opt (ek : exploration_kind) (l : BorrowId.id) (ctx : 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 *) @@ -218,17 +213,17 @@ let lookup_loan_opt (ek : exploration_kind) (l : V.BorrowId.id) let obj = object - inherit [_] C.iter_eval_ctx as super + inherit [_] iter_eval_ctx as super method! visit_borrow_content env bc = match bc with - | V.VSharedBorrow bid -> + | VSharedBorrow bid -> (* Nothing specific to do *) super#visit_VSharedBorrow env bid - | V.VReservedMutBorrow bid -> + | VReservedMutBorrow bid -> (* Nothing specific to do *) super#visit_VReservedMutBorrow env bid - | V.VMutBorrow (bid, mv) -> + | VMutBorrow (bid, mv) -> (* Control the dive *) if ek.enter_mut_borrows then super#visit_VMutBorrow env bid mv else () @@ -240,14 +235,14 @@ let lookup_loan_opt (ek : exploration_kind) (l : V.BorrowId.id) *) method! visit_loan_content env lc = match lc with - | V.VSharedLoan (bids, sv) -> + | VSharedLoan (bids, sv) -> (* Check if this is the loan we are looking for, and control the dive *) - if V.BorrowId.Set.mem l bids then + if BorrowId.Set.mem l bids then raise (FoundGLoanContent (Concrete lc)) else if ek.enter_shared_loans then super#visit_VSharedLoan env bids sv else () - | V.VMutLoan bid -> + | VMutLoan bid -> (* Check if this is the loan we are looking for *) if bid = l then raise (FoundGLoanContent (Concrete lc)) else super#visit_VMutLoan env bid @@ -257,19 +252,19 @@ let lookup_loan_opt (ek : exploration_kind) (l : V.BorrowId.id) (because there are no use cases requiring finer control) *) method! visit_aloan_content env lc = match lc with - | V.AMutLoan (bid, av) -> + | 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 + | ASharedLoan (bids, v, av) -> + if 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 + | AEndedMutLoan { given_back = _; child = _; given_back_meta = _ } + | AEndedSharedLoan (_, _) + | AIgnoredMutLoan (_, _) + | AEndedIgnoredMutLoan { given_back = _; child = _; given_back_meta = _ } - | V.AIgnoredSharedLoan _ -> + | AIgnoredSharedLoan _ -> super#visit_aloan_content env lc method! visit_EBinding env bv v = @@ -277,7 +272,7 @@ let lookup_loan_opt (ek : exploration_kind) (l : V.BorrowId.id) abs_or_var := Some (match bv with - | BVar b -> VarId b.C.index + | BVar b -> VarId b.index | BDummy id -> DummyVarId id); super#visit_EBinding env bv v; abs_or_var := None @@ -285,7 +280,7 @@ let lookup_loan_opt (ek : exploration_kind) (l : V.BorrowId.id) method! visit_EAbs env abs = assert (Option.is_none !abs_or_var); if ek.enter_abs then ( - abs_or_var := Some (AbsId abs.V.abs_id); + abs_or_var := Some (AbsId abs.abs_id); super#visit_EAbs env abs; abs_or_var := None) else () @@ -305,7 +300,7 @@ let lookup_loan_opt (ek : exploration_kind) (l : V.BorrowId.id) 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) : +let lookup_loan (ek : exploration_kind) (l : BorrowId.id) (ctx : eval_ctx) : abs_or_var_id * g_loan_content = match lookup_loan_opt ek l ctx with | None -> raise (Failure "Unreachable") @@ -317,13 +312,13 @@ let lookup_loan (ek : exploration_kind) (l : V.BorrowId.id) (ctx : C.eval_ctx) : 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 = +let update_loan (ek : exploration_kind) (l : BorrowId.id) (nlc : loan_content) + (ctx : eval_ctx) : 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 = + let update () : loan_content = assert (not !r); r := true; nlc @@ -331,7 +326,7 @@ let update_loan (ek : exploration_kind) (l : V.BorrowId.id) let obj = object - inherit [_] C.map_eval_ctx as super + inherit [_] map_eval_ctx as super method! visit_borrow_content env bc = match bc with @@ -350,7 +345,7 @@ let update_loan (ek : exploration_kind) (l : V.BorrowId.id) | VSharedLoan (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 () + if BorrowId.Set.mem l bids then update () else if ek.enter_shared_loans then super#visit_VSharedLoan env bids sv else VSharedLoan (bids, sv) @@ -380,13 +375,13 @@ let update_loan (ek : exploration_kind) (l : V.BorrowId.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 = +let update_aloan (ek : exploration_kind) (l : BorrowId.id) (nlc : aloan_content) + (ctx : eval_ctx) : 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 = + let update () : aloan_content = assert (not !r); r := true; nlc @@ -394,21 +389,21 @@ let update_aloan (ek : exploration_kind) (l : V.BorrowId.id) let obj = object - inherit [_] C.map_eval_ctx as super + inherit [_] map_eval_ctx as super method! visit_aloan_content env lc = match lc with - | V.AMutLoan (bid, av) -> + | 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 () + | ASharedLoan (bids, v, av) -> + if 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 + | AEndedMutLoan { given_back = _; child = _; given_back_meta = _ } + | AEndedSharedLoan (_, _) + | AIgnoredMutLoan (_, _) + | AEndedIgnoredMutLoan { given_back = _; child = _; given_back_meta = _ } - | V.AIgnoredSharedLoan _ -> + | AIgnoredSharedLoan _ -> super#visit_aloan_content env lc (** Note that once inside the abstractions, we don't control diving @@ -424,11 +419,11 @@ let update_aloan (ek : exploration_kind) (l : V.BorrowId.id) 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 lookup_borrow_opt (ek : exploration_kind) (l : BorrowId.id) (ctx : eval_ctx) + : g_borrow_content option = let obj = object - inherit [_] C.iter_eval_ctx as super + inherit [_] iter_eval_ctx as super method! visit_borrow_content env bc = match bc with @@ -486,8 +481,8 @@ let lookup_borrow_opt (ek : exploration_kind) (l : V.BorrowId.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 = +let lookup_borrow (ek : exploration_kind) (l : BorrowId.id) (ctx : eval_ctx) : + g_borrow_content = match lookup_borrow_opt ek l ctx with | None -> raise (Failure "Unreachable") | Some lc -> lc @@ -498,13 +493,13 @@ let lookup_borrow (ek : exploration_kind) (l : V.BorrowId.id) (ctx : C.eval_ctx) 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 = +let update_borrow (ek : exploration_kind) (l : BorrowId.id) + (nbc : borrow_content) (ctx : eval_ctx) : 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 = + let update () : borrow_content = assert (not !r); r := true; nbc @@ -512,7 +507,7 @@ let update_borrow (ek : exploration_kind) (l : V.BorrowId.id) let obj = object - inherit [_] C.map_eval_ctx as super + inherit [_] map_eval_ctx as super method! visit_borrow_content env bc = match bc with @@ -555,13 +550,13 @@ let update_borrow (ek : exploration_kind) (l : V.BorrowId.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 = +let update_aborrow (ek : exploration_kind) (l : BorrowId.id) (nv : avalue) + (ctx : eval_ctx) : 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 = + let update () : avalue = assert (not !r); r := true; nv @@ -569,22 +564,22 @@ let update_aborrow (ek : exploration_kind) (l : V.BorrowId.id) (nv : V.avalue) let obj = object - inherit [_] C.map_eval_ctx as super + inherit [_] map_eval_ctx as super method! visit_ABorrow env bc = match bc with - | V.AMutBorrow (bid, av) -> + | AMutBorrow (bid, av) -> if bid = l then update () - else V.ABorrow (super#visit_AMutBorrow env bid av) - | V.ASharedBorrow bid -> + else ABorrow (super#visit_AMutBorrow env bid av) + | ASharedBorrow bid -> if bid = l then update () - else V.ABorrow (super#visit_ASharedBorrow env bid) - | V.AIgnoredMutBorrow _ | V.AEndedMutBorrow _ | V.AEndedSharedBorrow - | V.AEndedIgnoredMutBorrow _ -> + else ABorrow (super#visit_ASharedBorrow env bid) + | AIgnoredMutBorrow _ | AEndedMutBorrow _ | AEndedSharedBorrow + | AEndedIgnoredMutBorrow _ -> super#visit_ABorrow env bc - | V.AProjSharedBorrow asb -> + | AProjSharedBorrow asb -> if borrow_in_asb l asb then update () - else V.ABorrow (super#visit_AProjSharedBorrow env asb) + else ABorrow (super#visit_AProjSharedBorrow env asb) method! visit_abs env abs = if ek.enter_abs then super#visit_abs env abs else abs @@ -597,16 +592,16 @@ let update_aborrow (ek : exploration_kind) (l : V.BorrowId.id) (nv : V.avalue) 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 update_outer_borrows (outer : AbstractionId.id option * borrow_ids option) + (x : borrow_ids) : 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 get_first_loan_in_value (v : typed_value) : loan_content option = let obj = object - inherit [_] V.iter_typed_value + inherit [_] iter_typed_value method! visit_loan_content _ lc = raise (FoundLoanContent lc) end in @@ -617,10 +612,10 @@ let get_first_loan_in_value (v : V.typed_value) : V.loan_content option = with FoundLoanContent lc -> Some lc (** Return the first loan we find in a list of values *) -let get_first_loan_in_values (vs : V.typed_value list) : V.loan_content option = +let get_first_loan_in_values (vs : typed_value list) : loan_content option = let obj = object - inherit [_] V.iter_typed_value + inherit [_] iter_typed_value method! visit_loan_content _ lc = raise (FoundLoanContent lc) end in @@ -631,10 +626,10 @@ let get_first_loan_in_values (vs : V.typed_value list) : V.loan_content option = 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 get_first_borrow_in_value (v : typed_value) : borrow_content option = let obj = object - inherit [_] V.iter_typed_value + inherit [_] iter_typed_value method! visit_borrow_content _ bc = raise (FoundBorrowContent bc) end in @@ -652,10 +647,10 @@ let get_first_borrow_in_value (v : V.typed_value) : V.borrow_content option = - 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 = + (v : typed_value) : loan_or_borrow_content option = let obj = object - inherit [_] V.iter_typed_value + inherit [_] iter_typed_value method! visit_borrow_content _ bc = if with_borrows then raise (FoundBorrowContent bc) else () @@ -671,17 +666,13 @@ let get_first_outer_loan_or_borrow_in_value (with_borrows : bool) | 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 = + (proj_borrows : RegionId.Set.t * symbolic_value * rty) + (proj_loans : RegionId.Set.t * 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 + projections_intersect l_sv.sv_ty l_regions b_ty b_regions else false (** Result of looking up aproj_borrows which intersect a given aproj_loans in @@ -698,8 +689,8 @@ let proj_borrows_intersects_proj_loans 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 + | NonSharedProj of AbstractionId.id * rty + | SharedProjs of (AbstractionId.id * rty) list (** Lookup the aproj_borrows (including aproj_shared_borrows) over a symbolic value which intersect a given set of regions. @@ -710,15 +701,15 @@ type looked_up_aproj_borrows = 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) : + (regions : RegionId.Set.t) (sv : symbolic_value) (ctx : 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 = + let set_non_shared ((id, ty) : AbstractionId.id * rty) : unit = match !found with | None -> found := Some (NonSharedProj (id, ty)) | Some _ -> raise (Failure "Unreachable") in - let add_shared (x : V.AbstractionId.id * T.rty) : unit = + let add_shared (x : AbstractionId.id * rty) : unit = match !found with | None -> found := Some (SharedProjs [ x ]) | Some (SharedProjs pl) -> found := Some (SharedProjs (x :: pl)) @@ -727,7 +718,7 @@ let lookup_intersecting_aproj_borrows_opt (lookup_shared : bool) let check_add_proj_borrows (is_shared : bool) abs sv' proj_ty = if proj_borrows_intersects_proj_loans - (abs.V.regions, sv', proj_ty) + (abs.regions, sv', proj_ty) (regions, sv) then let x = (abs.abs_id, proj_ty) in @@ -736,7 +727,7 @@ let lookup_intersecting_aproj_borrows_opt (lookup_shared : bool) in let obj = object - inherit [_] C.iter_eval_ctx as super + inherit [_] iter_eval_ctx as super method! visit_abs _ abs = super#visit_abs (Some abs) abs method! visit_abstract_shared_borrow abs asb = @@ -748,8 +739,8 @@ let lookup_intersecting_aproj_borrows_opt (lookup_shared : bool) if lookup_shared then let abs = Option.get abs in match asb with - | V.AsbBorrow _ -> () - | V.AsbProjReborrows (sv', proj_ty) -> + | AsbBorrow _ -> () + | AsbProjReborrows (sv', proj_ty) -> let is_shared = true in check_add_proj_borrows is_shared abs sv' proj_ty else () @@ -781,9 +772,8 @@ let lookup_intersecting_aproj_borrows_opt (lookup_shared : bool) 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_intersecting_aproj_borrows_not_shared_opt (regions : RegionId.Set.t) + (sv : symbolic_value) (ctx : eval_ctx) : (AbstractionId.id * rty) option = let lookup_shared = false in match lookup_intersecting_aproj_borrows_opt lookup_shared regions sv ctx with | None -> None @@ -796,10 +786,10 @@ let lookup_intersecting_aproj_borrows_not_shared_opt 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 = + (update_shared : AbstractionId.id -> rty -> abstract_shared_borrows) + (update_non_shared : AbstractionId.id -> rty -> aproj) + (regions : RegionId.Set.t) (sv : symbolic_value) (ctx : eval_ctx) : eval_ctx + = (* Small helpers for sanity checks *) let shared = ref None in let add_shared () = @@ -813,7 +803,7 @@ let update_intersecting_aproj_borrows (can_update_shared : bool) let check_proj_borrows is_shared abs sv' proj_ty = if proj_borrows_intersects_proj_loans - (abs.V.regions, sv', proj_ty) + (abs.regions, sv', proj_ty) (regions, sv) then ( if is_shared then add_shared () else set_non_shared (); @@ -823,7 +813,7 @@ let update_intersecting_aproj_borrows (can_update_shared : bool) (* The visitor *) let obj = object - inherit [_] C.map_eval_ctx as super + inherit [_] map_eval_ctx as super method! visit_abs _ abs = super#visit_abs (Some abs) abs method! visit_abstract_shared_borrows abs asb = @@ -832,11 +822,10 @@ let update_intersecting_aproj_borrows (can_update_shared : bool) (* Explore *) if can_update_shared then let abs = Option.get abs in - let update (asb : V.abstract_shared_borrow) : - V.abstract_shared_borrows = + let update (asb : abstract_shared_borrow) : abstract_shared_borrows = match asb with - | V.AsbBorrow _ -> [ asb ] - | V.AsbProjReborrows (sv', proj_ty) -> + | AsbBorrow _ -> [ asb ] + | 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 @@ -872,8 +861,8 @@ let update_intersecting_aproj_borrows (can_update_shared : bool) 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 = +let update_intersecting_aproj_borrows_non_shared (regions : RegionId.Set.t) + (sv : symbolic_value) (nv : aproj) (ctx : eval_ctx) : eval_ctx = (* Small helpers *) let can_update_shared = false in let update_shared _ _ = raise (Failure "Unexpected") in @@ -898,8 +887,8 @@ let update_intersecting_aproj_borrows_non_shared (regions : T.RegionId.Set.t) 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 = +let remove_intersecting_aproj_borrows_shared (regions : RegionId.Set.t) + (sv : symbolic_value) (ctx : eval_ctx) : eval_ctx = (* Small helpers *) let can_update_shared = true in let update_shared _ _ = [] in @@ -935,19 +924,19 @@ let remove_intersecting_aproj_borrows_shared (regions : T.RegionId.Set.t) [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}). + loans where we perform the substitution (see the fields in {!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 = +let update_intersecting_aproj_loans (proj_regions : RegionId.Set.t) + (proj_ty : rty) (sv : symbolic_value) + (subst : abs -> (msymbolic_value * aproj) list -> aproj) (ctx : eval_ctx) : + eval_ctx = (* *) assert (ty_is_rty proj_ty); (* Small helpers for sanity checks *) let updated = ref false in - let update abs local_given_back : V.aproj = + let update abs local_given_back : aproj = (* Note that we can update more than once! *) updated := true; subst abs local_given_back @@ -955,7 +944,7 @@ let update_intersecting_aproj_loans (proj_regions : T.RegionId.Set.t) (* The visitor *) let obj = object - inherit [_] C.map_eval_ctx as super + inherit [_] map_eval_ctx as super method! visit_abs _ abs = super#visit_abs (Some abs) abs method! visit_aproj abs sproj = @@ -968,8 +957,7 @@ let update_intersecting_aproj_loans (proj_regions : T.RegionId.Set.t) 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 + projections_intersect proj_ty proj_regions sv'.sv_ty abs.regions then update abs given_back else super#visit_aproj (Some abs) sproj) else super#visit_aproj (Some abs) sproj @@ -982,18 +970,18 @@ let update_intersecting_aproj_loans (proj_regions : T.RegionId.Set.t) (* Return *) ctx -(** Helper function: lookup an {!V.AProjLoans} by using an abstraction id and a +(** Helper function: lookup an {!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 + fields in {!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 = +let lookup_aproj_loans (abs_id : AbstractionId.id) (sv : symbolic_value) + (ctx : eval_ctx) : (msymbolic_value * aproj) list = (* Small helpers for sanity checks *) let found = ref None in let set_found x = @@ -1004,12 +992,12 @@ let lookup_aproj_loans (abs_id : V.AbstractionId.id) (sv : V.symbolic_value) (* The visitor *) let obj = object - inherit [_] C.iter_eval_ctx as super + inherit [_] 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 = + method! visit_aproj (abs : abs option) sproj = (match sproj with | AProjBorrows _ | AEndedProjLoans _ | AEndedProjBorrows _ | AIgnoredProjBorrows -> @@ -1037,8 +1025,8 @@ let lookup_aproj_loans (abs_id : V.AbstractionId.id) (sv : V.symbolic_value) 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 = +let update_aproj_loans (abs_id : AbstractionId.id) (sv : symbolic_value) + (nproj : aproj) (ctx : eval_ctx) : eval_ctx = (* Small helpers for sanity checks *) let found = ref false in let update () = @@ -1050,12 +1038,12 @@ let update_aproj_loans (abs_id : V.AbstractionId.id) (sv : V.symbolic_value) (* The visitor *) let obj = object - inherit [_] C.map_eval_ctx as super + inherit [_] 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 = + method! visit_aproj (abs : abs option) sproj = match sproj with | AProjBorrows _ | AEndedProjLoans _ | AEndedProjBorrows _ | AIgnoredProjBorrows -> @@ -1086,8 +1074,8 @@ let update_aproj_loans (abs_id : V.AbstractionId.id) (sv : V.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 = +let update_aproj_borrows (abs_id : AbstractionId.id) (sv : symbolic_value) + (nproj : aproj) (ctx : eval_ctx) : eval_ctx = (* Small helpers for sanity checks *) let found = ref false in let update () = @@ -1099,12 +1087,12 @@ let update_aproj_borrows (abs_id : V.AbstractionId.id) (sv : V.symbolic_value) (* The visitor *) let obj = object - inherit [_] C.map_eval_ctx as super + inherit [_] 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 = + method! visit_aproj (abs : abs option) sproj = match sproj with | AProjLoans _ | AEndedProjLoans _ | AEndedProjBorrows _ | AIgnoredProjBorrows -> @@ -1127,26 +1115,26 @@ let update_aproj_borrows (abs_id : V.AbstractionId.id) (sv : V.symbolic_value) (** Helper function: might break invariants. - Converts an {!V.AProjLoans} to an {!V.AEndedProjLoans}. The projector is identified + Converts an {!AProjLoans} to an {!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 = +let update_aproj_loans_to_ended (abs_id : AbstractionId.id) + (sv : symbolic_value) (ctx : eval_ctx) : 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 + let nproj = 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 = +let no_aproj_over_symbolic_in_context (sv : symbolic_value) (ctx : eval_ctx) : + unit = (* The visitor *) let obj = object - inherit [_] C.iter_eval_ctx as super + inherit [_] iter_eval_ctx as super method! visit_aproj env sproj = (match sproj with @@ -1167,26 +1155,26 @@ let no_aproj_over_symbolic_in_context (sv : V.symbolic_value) (ctx : C.eval_ctx) **Remark:** we don't take the *ignored* mut/shared loans into account. *) -let get_first_non_ignored_aloan_in_abstraction (abs : V.abs) : +let get_first_non_ignored_aloan_in_abstraction (abs : abs) : borrow_ids_or_symbolic_value option = (* Explore to find a loan *) let obj = object - inherit [_] V.iter_abs as super + inherit [_] 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 (_, _) -> + | AMutLoan (bid, _) -> raise (FoundBorrowIds (Borrow bid)) + | ASharedLoan (bids, _, _) -> raise (FoundBorrowIds (Borrows bids)) + | AEndedMutLoan { given_back = _; child = _; given_back_meta = _ } + | AEndedSharedLoan (_, _) -> super#visit_aloan_content env lc - | V.AIgnoredMutLoan (_, _) -> + | AIgnoredMutLoan (_, _) -> (* Ignore *) super#visit_aloan_content env lc - | V.AEndedIgnoredMutLoan + | AEndedIgnoredMutLoan { given_back = _; child = _; given_back_meta = _ } - | V.AIgnoredSharedLoan _ -> + | AIgnoredSharedLoan _ -> (* Ignore *) super#visit_aloan_content env lc @@ -1220,8 +1208,8 @@ let get_first_non_ignored_aloan_in_abstraction (abs : V.abs) : (* There are loan projections over symbolic values *) Some (SymbolicValue sv) -let lookup_shared_value_opt (ctx : C.eval_ctx) (bid : V.BorrowId.id) : - V.typed_value option = +let lookup_shared_value_opt (ctx : eval_ctx) (bid : BorrowId.id) : + typed_value option = match lookup_loan_opt ek_all bid ctx with | None -> None | Some (_, lc) -> ( @@ -1230,6 +1218,5 @@ let lookup_shared_value_opt (ctx : C.eval_ctx) (bid : V.BorrowId.id) : Some sv | _ -> None) -let lookup_shared_value (ctx : C.eval_ctx) (bid : V.BorrowId.id) : V.typed_value - = +let lookup_shared_value (ctx : eval_ctx) (bid : BorrowId.id) : typed_value = Option.get (lookup_shared_value_opt ctx bid) diff --git a/compiler/InterpreterExpansion.ml b/compiler/InterpreterExpansion.ml index 2b7ff7d0..ff21cd77 100644 --- a/compiler/InterpreterExpansion.ml +++ b/compiler/InterpreterExpansion.ml @@ -3,26 +3,21 @@ * 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 PV = PrimitiveValues -module V = Values -module E = Expressions -module C = Contexts -module Subst = Substitute -module Assoc = AssociatedTypes -module L = Logging +open Types +open PrimitiveValues +open Values +open Contexts open TypesUtils -module Inv = Invariants -module S = SynthesizeSymbolic module SA = SymbolicAst open Cps open ValuesUtils open InterpreterUtils open InterpreterProjectors -open InterpreterBorrows +open Print.EvalCtx +module S = SynthesizeSymbolic (** The local logger *) -let log = L.expansion_log +let log = Logging.expansion_log (** Projector kind *) type proj_kind = LoanProj | BorrowProj @@ -53,10 +48,10 @@ type proj_kind = LoanProj | BorrowProj 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) +let apply_symbolic_expansion_to_target_avalues (config : config) (allow_reborrows : bool) (proj_kind : proj_kind) - (original_sv : V.symbolic_value) (expansion : V.symbolic_expansion) - (ctx : C.eval_ctx) : C.eval_ctx = + (original_sv : symbolic_value) (expansion : symbolic_expansion) + (ctx : eval_ctx) : eval_ctx = (* Symbolic values contained in the expansion might contain already ended regions *) let check_symbolic_no_ended = false in (* Prepare reborrows registration *) @@ -66,7 +61,7 @@ let apply_symbolic_expansion_to_target_avalues (config : C.config) (* Visitor to apply the expansion *) let obj = object (self) - inherit [_] C.map_eval_ctx as super + inherit [_] 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 *) @@ -94,12 +89,12 @@ let apply_symbolic_expansion_to_target_avalues (config : C.config) (* 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 _, _ -> + | AEndedProjBorrows _, _ -> ASymbolic aproj + | 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 -> + ASymbolic (self#visit_aproj (Some current_abs) aproj) + | 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 *) @@ -107,14 +102,14 @@ let apply_symbolic_expansion_to_target_avalues (config : C.config) (* Apply the projector *) let projected_value = apply_proj_loans_on_symbolic_expansion proj_regions - ancestors_regions expansion original_sv.V.sv_ty + ancestors_regions expansion original_sv.sv_ty in (* Replace *) - projected_value.V.value) + projected_value.value) else (* Not the searched symbolic value: nothing to do *) super#visit_ASymbolic (Some current_abs) aproj - | V.AProjBorrows (sv, proj_ty), BorrowProj -> + | 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 @@ -132,15 +127,15 @@ let apply_symbolic_expansion_to_target_avalues (config : C.config) proj_regions ancestors_regions expansion proj_ty in (* Replace *) - projected_value.V.value + projected_value.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, _ -> + | AProjLoans _, BorrowProj + | AProjBorrows (_, _), LoanProj + | AIgnoredProjBorrows, _ -> (* Nothing to do *) - V.ASymbolic aproj + ASymbolic aproj end in (* Apply the expansion *) @@ -151,9 +146,9 @@ let apply_symbolic_expansion_to_target_avalues (config : C.config) (** 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_symbolic_expansion_to_avalues (config : config) + (allow_reborrows : bool) (original_sv : symbolic_value) + (expansion : symbolic_expansion) (ctx : eval_ctx) : eval_ctx = let apply_expansion proj_kind ctx = apply_symbolic_expansion_to_target_avalues config allow_reborrows proj_kind original_sv expansion ctx @@ -168,9 +163,8 @@ let apply_symbolic_expansion_to_avalues (config : C.config) 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 = +let replace_symbolic_values (at_most_once : bool) (original_sv : symbolic_value) + (nv : value) (ctx : eval_ctx) : eval_ctx = (* Count *) let replaced = ref false in let replace () = @@ -181,7 +175,7 @@ let replace_symbolic_values (at_most_once : bool) (* Visitor to apply the substitution *) let obj = object - inherit [_] C.map_eval_ctx as super + inherit [_] map_eval_ctx as super method! visit_VSymbolic env spc = if same_symbolic_id spc original_sv then replace () @@ -193,13 +187,13 @@ let replace_symbolic_values (at_most_once : bool) (* Return *) ctx -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 = +let apply_symbolic_expansion_non_borrow (config : config) + (original_sv : symbolic_value) (expansion : symbolic_expansion) + (ctx : eval_ctx) : 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 + let ctx = replace_symbolic_values at_most_once original_sv nv.value ctx in (* Apply the expansion to abstraction values *) let allow_reborrows = false in apply_symbolic_expansion_to_avalues config allow_reborrows original_sv @@ -216,47 +210,47 @@ let apply_symbolic_expansion_non_borrow (config : C.config) doesn't allow the expansion of enumerations *containing several variants*. *) let compute_expanded_symbolic_non_assumed_adt_value (expand_enumerations : bool) - (kind : V.sv_kind) (def_id : T.TypeDeclId.id) (generics : T.generic_args) - (ctx : C.eval_ctx) : V.symbolic_expansion list = + (kind : sv_kind) (def_id : TypeDeclId.id) (generics : generic_args) + (ctx : eval_ctx) : 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 generics.regions = List.length def.T.generics.regions); + let def = ctx_lookup_type_decl ctx def_id in + assert (List.length generics.regions = List.length def.generics.regions); (* Retrieve, for every variant, the list of its instantiated field types *) let variants_fields_types = - Assoc.type_decl_get_inst_norm_variants_fields_rtypes ctx def generics + AssociatedTypes.type_decl_get_inst_norm_variants_fields_rtypes ctx def + generics 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 initialize ((variant_id, field_types) : VariantId.id option * rty list) : + symbolic_expansion = let field_values = - List.map (fun (ty : T.rty) -> mk_fresh_symbolic_value kind ty) field_types + List.map (fun (ty : rty) -> mk_fresh_symbolic_value kind ty) field_types in - let see = V.SeAdt (variant_id, field_values) in + let see = SeAdt (variant_id, field_values) in see in (* Initialize all the expanded values of all the variants *) List.map initialize variants_fields_types -let compute_expanded_symbolic_tuple_value (kind : V.sv_kind) - (field_types : T.rty list) : V.symbolic_expansion = +let compute_expanded_symbolic_tuple_value (kind : sv_kind) + (field_types : rty list) : 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 + let see = SeAdt (variant_id, field_values) in see -let compute_expanded_symbolic_box_value (kind : V.sv_kind) (boxed_ty : T.rty) : - V.symbolic_expansion = +let compute_expanded_symbolic_box_value (kind : sv_kind) (boxed_ty : rty) : + 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 + let see = SeAdt (None, [ boxed_value ]) in see (** Compute the expansion of an adt value. @@ -269,51 +263,51 @@ let compute_expanded_symbolic_box_value (kind : V.sv_kind) (boxed_ty : T.rty) : doesn't allow the expansion of enumerations *containing several variants*. *) let compute_expanded_symbolic_adt_value (expand_enumerations : bool) - (kind : V.sv_kind) (adt_id : T.type_id) (generics : T.generic_args) - (ctx : C.eval_ctx) : V.symbolic_expansion list = + (kind : sv_kind) (adt_id : type_id) (generics : generic_args) + (ctx : eval_ctx) : symbolic_expansion list = match (adt_id, generics.regions, generics.types) with - | T.TAdtId def_id, _, _ -> + | TAdtId def_id, _, _ -> compute_expanded_symbolic_non_assumed_adt_value expand_enumerations kind def_id generics ctx - | T.TTuple, [], _ -> + | TTuple, [], _ -> [ compute_expanded_symbolic_tuple_value kind generics.types ] - | T.TAssumed T.TBox, [], [ boxed_ty ] -> + | TAssumed TBox, [], [ boxed_ty ] -> [ compute_expanded_symbolic_box_value kind boxed_ty ] | _ -> raise (Failure "compute_expanded_symbolic_adt_value: unexpected combination") -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 = +let expand_symbolic_value_shared_borrow (config : config) + (original_sv : symbolic_value) (original_sv_place : SA.mplace option) + (ref_ty : 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 borrows = ref BorrowId.Set.empty in let fresh_borrow () = - let bid' = C.fresh_borrow_id () in - borrows := V.BorrowId.Set.add bid' !borrows; + let bid' = fresh_borrow_id () in + borrows := 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 = + let reborrow_ashared proj_regions (sv : symbolic_value) (proj_ty : rty) : + abstract_shared_borrows option = if same_symbolic_id sv original_sv then match proj_ty with - | T.TRef (r, ref_ty, T.Shared) -> + | TRef (r, ref_ty, RShared) -> (* Projector over the shared value *) - let shared_asb = V.AsbProjReborrows (sv, ref_ty) in + let shared_asb = 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 ] + Some [ AsbBorrow bid; shared_asb ] else (* Not in the set: ignore *) Some [ shared_asb ] | _ -> raise (Failure "Unexpected") @@ -324,7 +318,7 @@ let expand_symbolic_value_shared_borrow (config : C.config) (* Visitor to replace the projectors on borrows *) let obj = object (self) - inherit [_] C.map_eval_ctx as super + inherit [_] map_eval_ctx as super method! visit_VSymbolic env sv = if same_symbolic_id sv original_sv then @@ -334,21 +328,21 @@ let expand_symbolic_value_shared_borrow (config : C.config) method! visit_EAbs proj_regions abs = assert (Option.is_none proj_regions); - let proj_regions = Some abs.V.regions in + let proj_regions = Some abs.regions in super#visit_EAbs proj_regions abs method! visit_AProjSharedBorrow proj_regions asb = - let expand_asb (asb : V.abstract_shared_borrow) : - V.abstract_shared_borrows = + let expand_asb (asb : abstract_shared_borrow) : abstract_shared_borrows + = match asb with - | V.AsbBorrow _ -> [ asb ] - | V.AsbProjReborrows (sv, proj_ty) -> ( + | AsbBorrow _ -> [ asb ] + | 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 + AProjSharedBorrow asb (** We carefully updated {!visit_ASymbolic} so that {!visit_aproj} is called only on child projections (i.e., projections which appear in {!AEndedProjLoans}). @@ -365,27 +359,27 @@ let expand_symbolic_value_shared_borrow (config : C.config) method! visit_ASymbolic proj_regions aproj = match aproj with | AEndedProjBorrows _ | AIgnoredProjBorrows -> - (* We ignore borrows *) V.ASymbolic aproj + (* We ignore borrows *) ASymbolic aproj | AProjLoans _ -> (* Loans are handled later *) - V.ASymbolic aproj + 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)) + | Some asb -> ABorrow (AProjSharedBorrow asb)) | AEndedProjLoans _ -> (* Sanity check: make sure there is nothing to expand inside the * children projections *) - V.ASymbolic (self#visit_aproj proj_regions aproj) + 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 + assert (not (BorrowId.Set.is_empty bids)); + let see = SeSharedRef (bids, shared_sv) in let allow_reborrows = true in let ctx = apply_symbolic_expansion_to_avalues config allow_reborrows original_sv see @@ -398,28 +392,26 @@ let expand_symbolic_value_shared_borrow (config : C.config) 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.region) (ref_ty : T.rty) (rkind : T.ref_kind) : cm_fun = +let expand_symbolic_value_borrow (config : config) + (original_sv : symbolic_value) (original_sv_place : SA.mplace option) + (region : region) (ref_ty : rty) (rkind : ref_kind) : cm_fun = fun cf ctx -> - assert (region <> T.RErased); + assert (region <> RErased); (* 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 -> + | RMut -> (* 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 + let bid = fresh_borrow_id () in + let see = 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 + let ctx = replace_symbolic_values at_most_once original_sv nv.value ctx in (* Expand the symbolic avalues *) let allow_reborrows = true in let ctx = @@ -431,7 +423,7 @@ let expand_symbolic_value_borrow (config : C.config) (* Update the synthesized program *) S.synthesize_symbolic_expansion_no_branching original_sv original_sv_place see expr - | T.Shared -> + | RShared -> expand_symbolic_value_shared_borrow config original_sv original_sv_place ref_ty cf ctx @@ -451,9 +443,9 @@ let expand_symbolic_value_borrow (config : C.config) We need this continuation separately (i.e., we can't compose it with the continuations in [see_cf_l]) because we perform a join *before* calling it. *) -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 * st_cm_fun) list) +let apply_branching_symbolic_expansions_non_borrow (config : config) + (sv : symbolic_value) (sv_place : SA.mplace option) + (see_cf_l : (symbolic_expansion option * st_cm_fun) list) (cf_after_join : st_m_fun) : m_fun = fun ctx -> assert (see_cf_l <> []); @@ -494,25 +486,25 @@ let apply_branching_symbolic_expansions_non_borrow (config : C.config) let seel = List.map fst see_cf_l in S.synthesize_symbolic_expansion sv sv_place seel subterms -let expand_symbolic_bool (config : C.config) (sv : V.symbolic_value) +let expand_symbolic_bool (config : config) (sv : symbolic_value) (sv_place : SA.mplace option) (cf_true : st_cm_fun) (cf_false : st_cm_fun) (cf_after_join : st_m_fun) : m_fun = fun ctx -> (* Compute the expanded value *) let original_sv = sv in let original_sv_place = sv_place in - let rty = original_sv.V.sv_ty in - assert (rty = T.TLiteral PV.TBool); + let rty = original_sv.sv_ty in + assert (rty = TLiteral TBool); (* Expand the symbolic value to true or false and continue execution *) - let see_true = V.SeLiteral (PV.VBool true) in - let see_false = V.SeLiteral (PV.VBool false) in + let see_true = SeLiteral (VBool true) in + let see_false = SeLiteral (VBool 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 cf_after_join ctx -let expand_symbolic_value_no_branching (config : C.config) - (sv : V.symbolic_value) (sv_place : SA.mplace option) : cm_fun = +let expand_symbolic_value_no_branching (config : config) (sv : symbolic_value) + (sv_place : SA.mplace option) : cm_fun = fun cf ctx -> (* Debug *) log#ldebug @@ -524,12 +516,12 @@ let expand_symbolic_value_no_branching (config : C.config) * fresh symbolic values in the context (which thus gets updated) *) let original_sv = sv in let original_sv_place = sv_place in - let rty = original_sv.V.sv_ty in + let rty = original_sv.sv_ty in let cc : cm_fun = fun cf ctx -> match rty with (* ADTs *) - | T.TAdt (adt_id, generics) -> + | TAdt (adt_id, generics) -> (* Compute the expanded value *) let allow_branching = false in let seel = @@ -548,14 +540,14 @@ let expand_symbolic_value_no_branching (config : C.config) S.synthesize_symbolic_expansion_no_branching original_sv original_sv_place see expr (* Borrows *) - | T.TRef (region, ref_ty, rkind) -> + | TRef (region, ref_ty, rkind) -> expand_symbolic_value_borrow config original_sv original_sv_place region ref_ty rkind cf ctx | _ -> raise (Failure ("expand_symbolic_value_no_branching: unexpected type: " - ^ T.show_rty rty)) + ^ show_rty rty)) in (* Debug *) let cc = @@ -567,12 +559,12 @@ let expand_symbolic_value_no_branching (config : C.config) ^ "\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))) + assert (not (symbolic_value_id_in_ctx original_sv.sv_id ctx))) in (* Continue *) cc cf ctx -let expand_symbolic_adt (config : C.config) (sv : V.symbolic_value) +let expand_symbolic_adt (config : config) (sv : symbolic_value) (sv_place : SA.mplace option) (cf_branches : st_cm_fun) (cf_after_join : st_m_fun) : m_fun = fun ctx -> @@ -582,11 +574,11 @@ let expand_symbolic_adt (config : C.config) (sv : V.symbolic_value) * fresh symbolic values in the context (which thus gets updated) *) let original_sv = sv in let original_sv_place = sv_place in - let rty = original_sv.V.sv_ty in + let rty = original_sv.sv_ty in (* Execute *) match rty with (* ADTs *) - | T.TAdt (adt_id, generics) -> + | TAdt (adt_id, generics) -> let allow_branching = true in (* Compute the expanded value *) let seel = @@ -598,15 +590,14 @@ let expand_symbolic_adt (config : C.config) (sv : V.symbolic_value) apply_branching_symbolic_expansions_non_borrow config original_sv original_sv_place seel cf_after_join ctx | _ -> - raise - (Failure ("expand_symbolic_adt: unexpected type: " ^ T.show_rty rty)) + raise (Failure ("expand_symbolic_adt: unexpected type: " ^ show_rty rty)) -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 * st_cm_fun) list) (otherwise : st_cm_fun) +let expand_symbolic_int (config : config) (sv : symbolic_value) + (sv_place : SA.mplace option) (int_type : integer_type) + (tgts : (scalar_value * st_cm_fun) list) (otherwise : st_cm_fun) (cf_after_join : st_m_fun) : m_fun = (* Sanity check *) - assert (sv.V.sv_ty = T.TLiteral (PV.TInteger int_type)); + assert (sv.sv_ty = TLiteral (TInteger 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 @@ -617,7 +608,7 @@ let expand_symbolic_int (config : C.config) (sv : V.symbolic_value) * (optional expansion, statement to execute) *) let seel = - List.map (fun (v, cf) -> (Some (V.SeLiteral (PV.VScalar v)), cf)) tgts + List.map (fun (v, cf) -> (Some (SeLiteral (VScalar v)), cf)) tgts in let seel = List.append seel [ (None, otherwise) ] in (* Then expand and evaluate - this generates the proper symbolic AST *) @@ -632,15 +623,15 @@ let expand_symbolic_int (config : C.config) (sv : V.symbolic_value) 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 = +let greedy_expand_symbolics_with_borrows (config : 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 + inherit [_] iter_eval_ctx method! visit_VSymbolic _ sv = - if ty_has_borrows ctx.type_context.type_infos sv.V.sv_ty then + if ty_has_borrows ctx.type_context.type_infos sv.sv_ty then raise (FoundSymbolicValue sv) else () @@ -669,7 +660,7 @@ let greedy_expand_symbolics_with_borrows (config : C.config) : cm_fun = (* {!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 + let def = ctx_lookup_type_decl ctx def_id in (match def.kind with | Struct _ | Enum ([] | [ _ ]) -> () | Enum (_ :: _) -> @@ -678,17 +669,17 @@ let greedy_expand_symbolics_with_borrows (config : C.config) : cm_fun = ("Attempted to greedily expand a symbolic enumeration \ with > 1 variants (option \ [greedy_expand_symbolics_with_borrows] of [config]): " - ^ Print.name_to_string def.name)) + ^ name_to_string ctx def.name)) | 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 + if 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)) + ^ name_to_string ctx def.name)) else expand_symbolic_value_no_branching config sv None | TAdt ((TTuple | TAssumed TBox), _) | TRef (_, _, _) -> (* Ok *) @@ -707,7 +698,7 @@ let greedy_expand_symbolics_with_borrows (config : C.config) : cm_fun = (* Apply *) expand cf ctx -let greedy_expand_symbolic_values (config : C.config) : cm_fun = +let greedy_expand_symbolic_values (config : config) : cm_fun = fun cf ctx -> if Config.greedy_expand_symbolics_with_borrows then ( log#ldebug (lazy "greedy_expand_symbolic_values"); diff --git a/compiler/InterpreterExpansion.mli b/compiler/InterpreterExpansion.mli index b9165ecb..6ea75d0b 100644 --- a/compiler/InterpreterExpansion.mli +++ b/compiler/InterpreterExpansion.mli @@ -1,15 +1,8 @@ -module T = Types -module PV = PrimitiveValues -module V = Values -module E = Expressions -module C = Contexts -module Subst = Substitute -module L = Logging -module Inv = Invariants -module S = SynthesizeSymbolic -module SA = SymbolicAst +open PrimitiveValues +open Values +open Contexts open Cps -open InterpreterBorrows +module SA = SymbolicAst type proj_kind = LoanProj | BorrowProj @@ -20,15 +13,11 @@ type proj_kind = LoanProj | BorrowProj This function does *not* update the synthesis. *) val apply_symbolic_expansion_non_borrow : - C.config -> - V.symbolic_value -> - V.symbolic_expansion -> - C.eval_ctx -> - C.eval_ctx + config -> symbolic_value -> symbolic_expansion -> eval_ctx -> eval_ctx (** Expand a symhbolic value, without branching *) val expand_symbolic_value_no_branching : - C.config -> V.symbolic_value -> SA.mplace option -> cm_fun + config -> symbolic_value -> SA.mplace option -> cm_fun (** Expand a symbolic enumeration (leads to branching if the enumeration has more than one variant). @@ -44,12 +33,7 @@ val expand_symbolic_value_no_branching : then call it). *) val expand_symbolic_adt : - C.config -> - V.symbolic_value -> - SA.mplace option -> - st_cm_fun -> - st_m_fun -> - m_fun + config -> symbolic_value -> SA.mplace option -> st_cm_fun -> st_m_fun -> m_fun (** Expand a symbolic boolean. @@ -58,8 +42,8 @@ val expand_symbolic_adt : parameter (here, there are exactly two branches). *) val expand_symbolic_bool : - C.config -> - V.symbolic_value -> + config -> + symbolic_value -> SA.mplace option -> st_cm_fun -> st_cm_fun -> @@ -86,16 +70,16 @@ val expand_symbolic_bool : switch. The continuation is thus for the execution *after* the switch. *) val expand_symbolic_int : - C.config -> - V.symbolic_value -> + config -> + symbolic_value -> SA.mplace option -> - T.integer_type -> - (V.scalar_value * st_cm_fun) list -> + integer_type -> + (scalar_value * st_cm_fun) list -> st_cm_fun -> st_m_fun -> m_fun (** If this mode is activated through the [config], greedily expand the symbolic - values which need to be expanded. See {!type:C.config} for more information. + values which need to be expanded. See {!type:config} for more information. *) -val greedy_expand_symbolic_values : C.config -> cm_fun +val greedy_expand_symbolic_values : config -> cm_fun diff --git a/compiler/InterpreterExpressions.ml b/compiler/InterpreterExpressions.ml index 58426cad..1e28fd4b 100644 --- a/compiler/InterpreterExpressions.ml +++ b/compiler/InterpreterExpressions.ml @@ -1,25 +1,21 @@ -module T = Types -module PV = PrimitiveValues -module V = Values -module LA = LlbcAst +open PrimitiveValues +open Types +open Values +open LlbcAst open Scalars -module E = Expressions +open Expressions open Utils -module C = Contexts -module Subst = Substitute -module Assoc = AssociatedTypes -module L = Logging +open Contexts open TypesUtils open ValuesUtils -module Inv = Invariants -module S = SynthesizeSymbolic +open SynthesizeSymbolic open Cps open InterpreterUtils open InterpreterExpansion open InterpreterPaths (** The local logger *) -let log = L.expressions_log +let log = Logging.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. @@ -29,8 +25,8 @@ let log = L.expressions_log 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 = +let expand_primitively_copyable_at_place (config : config) + (access : access_kind) (p : place) : cm_fun = fun cf ctx -> (* Small helper *) let rec expand : cm_fun = @@ -43,8 +39,7 @@ let expand_primitively_copyable_at_place (config : C.config) | None -> cf ctx | Some sv -> let cc = - expand_symbolic_value_no_branching config sv - (Some (S.mk_mplace p ctx)) + expand_symbolic_value_no_branching config sv (Some (mk_mplace p ctx)) in comp cc expand cf ctx in @@ -56,8 +51,8 @@ let expand_primitively_copyable_at_place (config : C.config) We also check that the value *doesn't contain bottoms or reserved borrows*. *) -let read_place (access : access_kind) (p : E.place) - (cf : V.typed_value -> m_fun) : m_fun = +let read_place (access : access_kind) (p : place) (cf : typed_value -> m_fun) : + m_fun = fun ctx -> let v = read_place access p ctx in (* Check that there are no bottoms in the value *) @@ -67,9 +62,9 @@ let read_place (access : access_kind) (p : E.place) (* Call the continuation *) cf v ctx -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 = +let access_rplace_reorganize_and_read (config : config) + (expand_prim_copy : bool) (access : access_kind) (p : place) + (cf : 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 @@ -87,16 +82,15 @@ let access_rplace_reorganize_and_read (config : C.config) (* 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 = +let access_rplace_reorganize (config : config) (expand_prim_copy : bool) + (access : access_kind) (p : 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 literal_to_typed_value (ty : PV.literal_type) (cv : V.literal) : - V.typed_value = +let literal_to_typed_value (ty : literal_type) (cv : literal) : typed_value = (* Check the type while converting - we actually need some information * contained in the type *) log#ldebug @@ -105,13 +99,13 @@ let literal_to_typed_value (ty : PV.literal_type) (cv : V.literal) : ^ Print.PrimitiveValues.literal_to_string cv)); match (ty, cv) with (* Scalar, boolean... *) - | PV.TBool, VBool v -> { V.value = V.VLiteral (VBool v); ty = T.TLiteral ty } - | TChar, VChar v -> { V.value = V.VLiteral (VChar v); ty = T.TLiteral ty } - | TInteger int_ty, PV.VScalar v -> + | TBool, VBool v -> { value = VLiteral (VBool v); ty = TLiteral ty } + | TChar, VChar v -> { value = VLiteral (VChar v); ty = TLiteral ty } + | TInteger int_ty, VScalar v -> (* Check the type and the ranges *) assert (int_ty = v.int_ty); assert (check_scalar_value_in_range v); - { V.value = V.VLiteral (PV.VScalar v); ty = T.TLiteral ty } + { value = VLiteral (VScalar v); ty = TLiteral ty } (* Remaining cases (invalid) *) | _, _ -> raise (Failure "Improperly typed constant value") @@ -126,8 +120,8 @@ let literal_to_typed_value (ty : PV.literal_type) (cv : V.literal) : parameter to control this copy ([allow_adt_copy]). Note that here by ADT we mean the user-defined ADTs (not tuples or assumed types). *) -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 = +let rec copy_value (allow_adt_copy : bool) (config : config) (ctx : eval_ctx) + (v : typed_value) : eval_ctx * typed_value = log#ldebug (lazy ("copy_value: " @@ -170,7 +164,7 @@ let rec copy_value (allow_adt_copy : bool) (config : C.config) | VSharedBorrow 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 bid' = fresh_borrow_id () in let ctx = InterpreterBorrows.reborrow_shared bid bid' ctx in (ctx, { v with value = VBorrow (VSharedBorrow bid') }) | VMutBorrow (_, _) -> raise (Failure "Can't copy a mutable borrow") @@ -188,7 +182,7 @@ let rec copy_value (allow_adt_copy : bool) (config : C.config) * 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.sv_ty)); + assert (ty_is_primitively_copyable (Substitute.erase_regions sp.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 @@ -233,8 +227,7 @@ let rec copy_value (allow_adt_copy : bool) (config : C.config) what we do in the formalization (because we don't enforce the same constraints as MIR in the formalization). *) -let prepare_eval_operand_reorganize (config : C.config) (op : E.operand) : - cm_fun = +let prepare_eval_operand_reorganize (config : config) (op : operand) : cm_fun = fun cf ctx -> let prepare : cm_fun = fun cf ctx -> @@ -258,8 +251,8 @@ let prepare_eval_operand_reorganize (config : C.config) (op : E.operand) : 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 = +let eval_operand_no_reorganize (config : config) (op : operand) + (cf : typed_value -> m_fun) : m_fun = fun ctx -> (* Debug *) log#ldebug @@ -271,11 +264,11 @@ let eval_operand_no_reorganize (config : C.config) (op : E.operand) | Constant cv -> ( match cv.value with | CLiteral lit -> - cf (literal_to_typed_value (TypesUtils.ty_as_literal cv.ty) lit) ctx + cf (literal_to_typed_value (ty_as_literal cv.ty) lit) ctx | CTraitConst (trait_ref, generics, const_name) -> ( - assert (generics = TypesUtils.mk_empty_generic_args); + assert (generics = empty_generic_args); match trait_ref.trait_id with - | T.TraitImpl _ -> + | TraitImpl _ -> (* This shouldn't happen: if we refer to a concrete implementation, we should directly refer to the top-level constant *) raise (Failure "Unreachable") @@ -285,14 +278,13 @@ let eval_operand_no_reorganize (config : C.config) (op : E.operand) let ctx0 = ctx in (* Lookup the trait declaration to retrieve the type of the symbolic value *) let trait_decl = - C.ctx_lookup_trait_decl ctx - trait_ref.trait_decl_ref.trait_decl_id + ctx_lookup_trait_decl ctx trait_ref.trait_decl_ref.trait_decl_id in let _, (ty, _) = List.find (fun (name, _) -> name = const_name) trait_decl.consts in (* Introduce a fresh symbolic value *) - let v = mk_fresh_symbolic_typed_value V.TraitConst ty in + let v = mk_fresh_symbolic_typed_value TraitConst ty in (* Continue the evaluation *) let e = cf v ctx in (* We have to wrap the generated expression *) @@ -310,7 +302,7 @@ let eval_operand_no_reorganize (config : C.config) (op : E.operand) | CVar vid -> ( let ctx0 = ctx in (* Lookup the const generic value *) - let cv = C.ctx_lookup_const_generic_value ctx vid in + let cv = ctx_lookup_const_generic_value ctx vid in (* Copy the value *) let allow_adt_copy = false in let ctx, v = copy_value allow_adt_copy config ctx cv in @@ -322,7 +314,7 @@ let eval_operand_no_reorganize (config : C.config) (op : E.operand) | Some e -> (* If we are synthesizing a symbolic AST, it means that we are in symbolic mode: the value of the const generic is necessarily symbolic. *) - assert (is_symbolic cv.V.value); + assert (is_symbolic cv.value); (* *) Some (SymbolicAst.IntroSymbolic @@ -362,15 +354,15 @@ let eval_operand_no_reorganize (config : C.config) (op : E.operand) 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 = VBottom; ty = v.ty } in + let bottom : typed_value = { value = VBottom; ty = v.ty } in let ctx = write_place access p bottom ctx in cf v ctx in (* Compose and apply *) comp cc move cf ctx -let eval_operand (config : C.config) (op : E.operand) - (cf : V.typed_value -> m_fun) : m_fun = +let eval_operand (config : config) (op : operand) (cf : typed_value -> m_fun) : + m_fun = fun ctx -> (* Debug *) log#ldebug @@ -387,13 +379,13 @@ let eval_operand (config : C.config) (op : E.operand) See [prepare_eval_operand_reorganize]. *) -let prepare_eval_operands_reorganize (config : C.config) (ops : E.operand list) - : cm_fun = +let prepare_eval_operands_reorganize (config : config) (ops : 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 = +let eval_operands (config : config) (ops : operand list) + (cf : typed_value list -> m_fun) : m_fun = fun ctx -> (* Prepare the operands *) let prepare = prepare_eval_operands_reorganize config ops in @@ -404,8 +396,8 @@ let eval_operands (config : C.config) (ops : E.operand list) (* 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_two_operands (config : config) (op1 : operand) (op2 : operand) + (cf : typed_value * typed_value -> m_fun) : m_fun = let eval_op = eval_operands config [ op1; op2 ] in let use_res cf res = match res with @@ -414,73 +406,73 @@ let eval_two_operands (config : C.config) (op1 : E.operand) (op2 : E.operand) 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 = +let eval_unary_op_concrete (config : config) (unop : unop) (op : operand) + (cf : (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.VLiteral (VBool b) -> - cf (Ok { v with V.value = V.VLiteral (VBool (not b)) }) - | E.Neg, V.VLiteral (PV.VScalar sv) -> ( - let i = Z.neg sv.PV.value in + let apply cf (v : typed_value) : m_fun = + match (unop, v.value) with + | Not, VLiteral (VBool b) -> + cf (Ok { v with value = VLiteral (VBool (not b)) }) + | Neg, VLiteral (VScalar sv) -> ( + let i = Z.neg sv.value in match mk_scalar sv.int_ty i with | Error _ -> cf (Error EPanic) - | Ok sv -> cf (Ok { v with V.value = V.VLiteral (PV.VScalar sv) })) - | E.Cast (E.CastInteger (src_ty, tgt_ty)), V.VLiteral (PV.VScalar sv) -> ( + | Ok sv -> cf (Ok { v with value = VLiteral (VScalar sv) })) + | Cast (CastInteger (src_ty, tgt_ty)), VLiteral (VScalar sv) -> ( assert (src_ty = sv.int_ty); - let i = sv.PV.value in + let i = sv.value in match mk_scalar tgt_ty i with | Error _ -> cf (Error EPanic) | Ok sv -> - let ty = T.TLiteral (TInteger tgt_ty) in - let value = V.VLiteral (PV.VScalar sv) in - cf (Ok { V.ty; value })) + let ty = TLiteral (TInteger tgt_ty) in + let value = VLiteral (VScalar sv) in + cf (Ok { 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 = +let eval_unary_op_symbolic (config : config) (unop : unop) (op : operand) + (cf : (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 = + let apply cf (v : typed_value) : m_fun = fun ctx -> - let res_sv_id = C.fresh_symbolic_value_id () in + let res_sv_id = fresh_symbolic_value_id () in let res_sv_ty = - match (unop, v.V.ty) with - | E.Not, (T.TLiteral TBool as lty) -> lty - | E.Neg, (T.TLiteral (TInteger _) as lty) -> lty - | E.Cast (E.CastInteger (_, tgt_ty)), _ -> T.TLiteral (TInteger tgt_ty) + match (unop, v.ty) with + | Not, (TLiteral TBool as lty) -> lty + | Neg, (TLiteral (TInteger _) as lty) -> lty + | Cast (CastInteger (_, tgt_ty)), _ -> TLiteral (TInteger 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 } + { sv_kind = FunCallRet; 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 ctx unop v - (S.mk_opt_place_from_op op ctx) + synthesize_unary_op ctx unop v + (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 = +let eval_unary_op (config : config) (unop : unop) (op : operand) + (cf : (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 + | ConcreteMode -> eval_unary_op_concrete config unop op cf + | 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 = +let eval_binary_op_concrete_compute (binop : binop) (v1 : typed_value) + (v2 : typed_value) : (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 ( @@ -489,53 +481,52 @@ let eval_binary_op_concrete_compute (binop : E.binop) (v1 : V.typed_value) (* 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.VLiteral (VBool b); ty = T.TLiteral TBool }) + Ok { value = VLiteral (VBool b); ty = TLiteral TBool }) else (* For the non-equality operations, the input values are necessarily scalars *) - match (v1.V.value, v2.V.value) with - | V.VLiteral (PV.VScalar sv1), V.VLiteral (PV.VScalar sv2) -> ( + match (v1.value, v2.value) with + | VLiteral (VScalar sv1), VLiteral (VScalar 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 -> + | Lt | Le | Ge | 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.PV.value sv2.PV.value - | E.Le -> Z.leq sv1.PV.value sv2.PV.value - | E.Ge -> Z.geq sv1.PV.value sv2.PV.value - | E.Gt -> Z.gt sv1.PV.value sv2.PV.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 -> + | Lt -> Z.lt sv1.value sv2.value + | Le -> Z.leq sv1.value sv2.value + | Ge -> Z.geq sv1.value sv2.value + | Gt -> Z.gt sv1.value sv2.value + | Div | Rem | Add | Sub | Mul | BitXor | BitAnd | BitOr | Shl + | Shr | Ne | Eq -> raise (Failure "Unreachable") in Ok - ({ V.value = V.VLiteral (VBool b); ty = T.TLiteral TBool } - : V.typed_value) - | E.Div | E.Rem | E.Add | E.Sub | E.Mul | E.BitXor | E.BitAnd | E.BitOr - -> ( + ({ value = VLiteral (VBool b); ty = TLiteral TBool } + : typed_value) + | Div | Rem | Add | Sub | Mul | BitXor | BitAnd | 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.PV.value = Z.zero then Error () - else mk_scalar sv1.int_ty (Z.div sv1.PV.value sv2.PV.value) - | E.Rem -> + | Div -> + if sv2.value = Z.zero then Error () + else mk_scalar sv1.int_ty (Z.div sv1.value sv2.value) + | Rem -> (* See [https://github.com/ocaml/Zarith/blob/master/z.mli] *) - if sv2.PV.value = Z.zero then Error () - else mk_scalar sv1.int_ty (Z.rem sv1.PV.value sv2.PV.value) - | E.Add -> mk_scalar sv1.int_ty (Z.add sv1.PV.value sv2.PV.value) - | E.Sub -> mk_scalar sv1.int_ty (Z.sub sv1.PV.value sv2.PV.value) - | E.Mul -> mk_scalar sv1.int_ty (Z.mul sv1.PV.value sv2.PV.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 -> + if sv2.value = Z.zero then Error () + else mk_scalar sv1.int_ty (Z.rem sv1.value sv2.value) + | Add -> mk_scalar sv1.int_ty (Z.add sv1.value sv2.value) + | Sub -> mk_scalar sv1.int_ty (Z.sub sv1.value sv2.value) + | Mul -> mk_scalar sv1.int_ty (Z.mul sv1.value sv2.value) + | BitXor -> raise Unimplemented + | BitAnd -> raise Unimplemented + | BitOr -> raise Unimplemented + | Lt | Le | Ge | Gt | Shl | Shr | Ne | Eq -> raise (Failure "Unreachable") in match res with @@ -543,97 +534,93 @@ let eval_binary_op_concrete_compute (binop : E.binop) (v1 : V.typed_value) | Ok sv -> Ok { - V.value = V.VLiteral (PV.VScalar sv); - ty = T.TLiteral (TInteger sv1.int_ty); + value = VLiteral (VScalar sv); + ty = TLiteral (TInteger sv1.int_ty); }) - | E.Shl | E.Shr -> raise Unimplemented - | E.Ne | E.Eq -> raise (Failure "Unreachable")) + | Shl | Shr -> raise Unimplemented + | Ne | 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 = +let eval_binary_op_concrete (config : config) (binop : binop) (op1 : operand) + (op2 : operand) (cf : (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 compute cf (res : typed_value * 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 = +let eval_binary_op_symbolic (config : config) (binop : binop) (op1 : operand) + (op2 : operand) (cf : (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 = + let compute cf ((v1, v2) : typed_value * 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_id = 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.TLiteral TBool) + TLiteral TBool) else (* Other operations: input types are integers *) - match (v1.V.ty, v2.V.ty) with - | T.TLiteral (TInteger int_ty1), T.TLiteral (TInteger int_ty2) -> ( + match (v1.ty, v2.ty) with + | TLiteral (TInteger int_ty1), TLiteral (TInteger int_ty2) -> ( match binop with - | E.Lt | E.Le | E.Ge | E.Gt -> + | Lt | Le | Ge | Gt -> assert (int_ty1 = int_ty2); - T.TLiteral TBool - | E.Div | E.Rem | E.Add | E.Sub | E.Mul | E.BitXor | E.BitAnd - | E.BitOr -> + TLiteral TBool + | Div | Rem | Add | Sub | Mul | BitXor | BitAnd | BitOr -> assert (int_ty1 = int_ty2); - T.TLiteral (TInteger int_ty1) - | E.Shl | E.Shr -> raise Unimplemented - | E.Ne | E.Eq -> raise (Failure "Unreachable")) + TLiteral (TInteger int_ty1) + | Shl | Shr -> raise Unimplemented + | Ne | 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 } + { sv_kind = FunCallRet; 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 ctx binop v1 p1 v2 p2 res_sv None expr + let p1 = mk_opt_place_from_op op1 ctx in + let p2 = mk_opt_place_from_op op2 ctx in + synthesize_binary_op ctx 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 - = +let eval_binary_op (config : config) (binop : binop) (op1 : operand) + (op2 : operand) (cf : (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 + | ConcreteMode -> eval_binary_op_concrete config binop op1 op2 cf + | SymbolicMode -> eval_binary_op_symbolic config binop op1 op2 cf -let eval_rvalue_ref (config : C.config) (p : E.place) (bkind : E.borrow_kind) - (cf : V.typed_value -> m_fun) : m_fun = +let eval_rvalue_ref (config : config) (p : place) (bkind : borrow_kind) + (cf : typed_value -> m_fun) : m_fun = fun ctx -> match bkind with - | Shared | TwoPhaseMut | Shallow -> + | BShared | BTwoPhaseMut | BShallow -> (* **REMARK**: we initially treated shallow borrows like shared borrows. In practice this restricted the behaviour too much, so for now we forbid them. *) - assert (bkind <> Shallow); + assert (bkind <> BShallow); (* Access the value *) let access = match bkind with - | Shared | Shallow -> Read - | TwoPhaseMut -> Write + | BShared | BShallow -> Read + | BTwoPhaseMut -> Write | _ -> raise (Failure "Unreachable") in @@ -642,22 +629,20 @@ let eval_rvalue_ref (config : C.config) (p : E.place) (bkind : E.borrow_kind) 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 = + let eval (cf : typed_value -> m_fun) (v : typed_value) : m_fun = fun ctx -> (* Generate the fresh borrow id *) - let bid = C.fresh_borrow_id () in + let bid = fresh_borrow_id () in (* Compute the loan value, with which to replace the value at place p *) let nv = match v.value with | VLoan (VSharedLoan (bids, sv)) -> (* Shared loan: insert the new borrow id *) - let bids1 = V.BorrowId.Set.add bid bids in + let bids1 = BorrowId.Set.add bid bids in { v with value = VLoan (VSharedLoan (bids1, sv)) } | _ -> (* Not a shared loan: add a wrapper *) - let v' = - V.VLoan (VSharedLoan (V.BorrowId.Set.singleton bid, v)) - in + let v' = VLoan (VSharedLoan (BorrowId.Set.singleton bid, v)) in { v with value = v' } in (* Update the borrowed value in the context *) @@ -666,27 +651,27 @@ let eval_rvalue_ref (config : C.config) (p : E.place) (bkind : E.borrow_kind) * Note that the reference is *mutable* if we do a two-phase borrow *) let ref_kind = match bkind with - | Shared | Shallow -> T.Shared - | TwoPhaseMut -> T.Mut + | BShared | BShallow -> RShared + | BTwoPhaseMut -> RMut | _ -> raise (Failure "Unreachable") in - let rv_ty = T.TRef (T.RErased, v.ty, ref_kind) in + let rv_ty = TRef (RErased, v.ty, ref_kind) in let bc = match bkind with - | Shared | Shallow -> + | BShared | BShallow -> (* See the remark at the beginning of the match branch: we handle shallow borrows like shared borrows *) - V.VSharedBorrow bid - | TwoPhaseMut -> VReservedMutBorrow bid + VSharedBorrow bid + | BTwoPhaseMut -> VReservedMutBorrow bid | _ -> raise (Failure "Unreachable") in - let rv : V.typed_value = { value = VBorrow bc; ty = rv_ty } in + let rv : typed_value = { value = VBorrow bc; ty = rv_ty } in (* Continue *) cf rv ctx in (* Compose and apply *) comp prepare eval cf ctx - | Mut -> + | BMut -> (* Access the value *) let access = Write in let expand_prim_copy = false in @@ -694,13 +679,13 @@ let eval_rvalue_ref (config : C.config) (p : E.place) (bkind : E.borrow_kind) 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 = + let eval (cf : typed_value -> m_fun) (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.TRef (RErased, v.ty, Mut) in - let rv : V.typed_value = - { V.value = VBorrow (VMutBorrow (bid, v)); ty = rv_ty } + let bid = fresh_borrow_id () in + let rv_ty = TRef (RErased, v.ty, RMut) in + let rv : typed_value = + { value = VBorrow (VMutBorrow (bid, v)); ty = rv_ty } in (* Compute the value with which to replace the value at place p *) let nv = { v with value = VLoan (VMutLoan bid) } in @@ -712,63 +697,61 @@ let eval_rvalue_ref (config : C.config) (p : E.place) (bkind : E.borrow_kind) (* 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 = +let eval_rvalue_aggregate (config : config) (aggregate_kind : aggregate_kind) + (ops : operand list) (cf : 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 = + let compute (cf : typed_value -> m_fun) (values : typed_value list) : m_fun = fun ctx -> (* Match on the aggregate kind *) match aggregate_kind with | AggregatedAdt (type_id, opt_variant_id, generics) -> ( match type_id with | TTuple -> - let tys = List.map (fun (v : V.typed_value) -> v.V.ty) values in - let v = V.VAdt { variant_id = None; field_values = values } in - let generics = TypesUtils.mk_generic_args [] tys [] [] in - let ty = T.TAdt (T.TTuple, generics) in - let aggregated : V.typed_value = { V.value = v; ty } in + let tys = List.map (fun (v : typed_value) -> v.ty) values in + let v = VAdt { variant_id = None; field_values = values } in + let generics = mk_generic_args [] tys [] [] in + let ty = TAdt (TTuple, generics) in + let aggregated : typed_value = { value = v; ty } in (* Call the continuation *) cf aggregated ctx | TAdtId def_id -> (* Sanity checks *) - let type_decl = C.ctx_lookup_type_decl ctx def_id in + let type_decl = ctx_lookup_type_decl ctx def_id in assert ( List.length type_decl.generics.regions = List.length generics.regions); let expected_field_types = - Assoc.ctx_adt_get_inst_norm_field_etypes ctx def_id opt_variant_id - generics + AssociatedTypes.ctx_adt_get_inst_norm_field_etypes ctx def_id + opt_variant_id generics in assert ( expected_field_types - = List.map (fun (v : V.typed_value) -> v.V.ty) values); + = List.map (fun (v : typed_value) -> v.ty) values); (* Construct the value *) - let av : V.adt_value = - { V.variant_id = opt_variant_id; V.field_values = values } + let av : adt_value = + { variant_id = opt_variant_id; field_values = values } in - let aty = T.TAdt (T.TAdtId def_id, generics) in - let aggregated : V.typed_value = { V.value = VAdt av; ty = aty } in + let aty = TAdt (TAdtId def_id, generics) in + let aggregated : typed_value = { value = VAdt av; ty = aty } in (* Call the continuation *) cf aggregated ctx | TAssumed _ -> raise (Failure "Unreachable")) | AggregatedArray (ety, cg) -> ( (* Sanity check: all the values have the proper type *) - assert (List.for_all (fun (v : V.typed_value) -> v.V.ty = ety) values); + assert (List.for_all (fun (v : typed_value) -> v.ty = ety) values); (* Sanity check: the number of values is consistent with the length *) let len = (literal_as_scalar (const_generic_as_literal cg)).value in assert (len = Z.of_int (List.length values)); let generics = TypesUtils.mk_generic_args [] [ ety ] [ cg ] [] in - let ty = T.TAdt (T.TAssumed T.TArray, generics) in + let ty = TAdt (TAssumed TArray, generics) in (* In order to generate a better AST, we introduce a symbolic value equal to the array. The reason is that otherwise, the array we introduce here might be duplicated in the generated code: by introducing a symbolic value we introduce a let-binding in the generated code. *) - let saggregated = mk_fresh_symbolic_typed_value V.Aggregate ty in + let saggregated = mk_fresh_symbolic_typed_value Aggregate ty in (* Call the continuation *) match cf saggregated ctx with | None -> None @@ -780,32 +763,32 @@ let eval_rvalue_aggregate (config : C.config) (* Compose and apply *) comp eval_ops compute cf -let eval_rvalue_not_global (config : C.config) (rvalue : E.rvalue) - (cf : (V.typed_value, eval_error) result -> m_fun) : m_fun = +let eval_rvalue_not_global (config : config) (rvalue : rvalue) + (cf : (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 = + let wrap_in_result (cf : (typed_value, eval_error) result -> m_fun) + (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.RvRef (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) -> + | Use op -> comp_wrap (eval_operand config op) ctx + | RvRef (p, bkind) -> comp_wrap (eval_rvalue_ref config p bkind) ctx + | UnaryOp (unop, op) -> eval_unary_op config unop op cf ctx + | BinaryOp (binop, op1, op2) -> eval_binary_op config binop op1 op2 cf ctx + | Aggregate (aggregate_kind, ops) -> comp_wrap (eval_rvalue_aggregate config aggregate_kind ops) ctx - | E.Discriminant _ -> + | Discriminant _ -> raise (Failure "Unreachable: discriminant reads should have been eliminated from \ the AST") - | E.Global _ -> raise (Failure "Unreachable") + | Global _ -> raise (Failure "Unreachable") -let eval_fake_read (config : C.config) (p : E.place) : cm_fun = +let eval_fake_read (config : config) (p : place) : cm_fun = fun cf ctx -> let expand_prim_copy = false in let cf_prepare cf = diff --git a/compiler/InterpreterExpressions.mli b/compiler/InterpreterExpressions.mli index 3beba610..f8d979f4 100644 --- a/compiler/InterpreterExpressions.mli +++ b/compiler/InterpreterExpressions.mli @@ -1,13 +1,6 @@ -module T = Types -module PV = PrimitiveValues -module V = Values -module LA = LlbcAst -module E = Expressions -module C = Contexts -module Subst = Substitute -module L = Logging -module Inv = Invariants -module S = SynthesizeSymbolic +open Expressions +open Values +open Contexts open Cps open InterpreterPaths @@ -19,7 +12,7 @@ open InterpreterPaths This function doesn't reorganize the context to make sure we can read the place. If needs be, you should call {!InterpreterPaths.update_ctx_along_read_place} first. *) -val read_place : access_kind -> E.place -> (V.typed_value -> m_fun) -> m_fun +val read_place : access_kind -> place -> (typed_value -> m_fun) -> m_fun (** Auxiliary function. @@ -38,12 +31,7 @@ val read_place : access_kind -> E.place -> (V.typed_value -> m_fun) -> m_fun primitively copyable and contain borrows. *) val access_rplace_reorganize_and_read : - C.config -> - bool -> - access_kind -> - E.place -> - (V.typed_value -> m_fun) -> - m_fun + config -> bool -> access_kind -> place -> (typed_value -> m_fun) -> m_fun (** Evaluate an operand. @@ -54,11 +42,11 @@ val access_rplace_reorganize_and_read : of the environment, before evaluating all the operands at once. Use {!eval_operands} instead. *) -val eval_operand : C.config -> E.operand -> (V.typed_value -> m_fun) -> m_fun +val eval_operand : config -> operand -> (typed_value -> m_fun) -> m_fun (** Evaluate several operands at once. *) val eval_operands : - C.config -> E.operand list -> (V.typed_value list -> m_fun) -> m_fun + config -> operand list -> (typed_value list -> m_fun) -> m_fun (** Evaluate an rvalue which is not a global (globals are handled elsewhere). @@ -68,7 +56,7 @@ val eval_operands : reads should have been eliminated from the AST. *) val eval_rvalue_not_global : - C.config -> E.rvalue -> ((V.typed_value, eval_error) result -> m_fun) -> m_fun + config -> rvalue -> ((typed_value, eval_error) result -> m_fun) -> m_fun (** Evaluate a fake read (update the context so that we can read a place) *) -val eval_fake_read : C.config -> E.place -> cm_fun +val eval_fake_read : config -> place -> cm_fun diff --git a/compiler/InterpreterLoops.ml b/compiler/InterpreterLoops.ml index 5b170ac5..30b9316d 100644 --- a/compiler/InterpreterLoops.ml +++ b/compiler/InterpreterLoops.ml @@ -5,7 +5,6 @@ module E = Expressions module C = Contexts module Subst = Substitute module A = LlbcAst -module L = Logging open ValuesUtils module Inv = Invariants module S = SynthesizeSymbolic @@ -16,7 +15,7 @@ open InterpreterLoopsMatchCtxs open InterpreterLoopsFixedPoint (** The local logger *) -let log = L.loops_log +let log = Logging.loops_log (** Evaluate a loop in concrete mode *) let eval_loop_concrete (eval_loop_body : st_cm_fun) : st_cm_fun = diff --git a/compiler/InterpreterLoopsCore.ml b/compiler/InterpreterLoopsCore.ml index 50bc7767..d14230c6 100644 --- a/compiler/InterpreterLoopsCore.ml +++ b/compiler/InterpreterLoopsCore.ml @@ -1,26 +1,17 @@ (** Core definitions for the [IntepreterLoops*] *) -module T = Types -module PV = PrimitiveValues -module V = Values -module E = Expressions -module C = Contexts -module Subst = Substitute -module A = LlbcAst -module L = Logging -module Inv = Invariants -module S = SynthesizeSymbolic -module UF = UnionFind +open Types +open Values +open Contexts open InterpreterUtils -open InterpreterExpressions type updt_env_kind = - | AbsInLeft of V.AbstractionId.id - | LoanInLeft of V.BorrowId.id - | LoansInLeft of V.BorrowId.Set.t - | AbsInRight of V.AbstractionId.id - | LoanInRight of V.BorrowId.id - | LoansInRight of V.BorrowId.Set.t + | AbsInLeft of AbstractionId.id + | LoanInLeft of BorrowId.id + | LoansInLeft of BorrowId.Set.t + | AbsInRight of AbstractionId.id + | LoanInRight of BorrowId.id + | LoansInRight of BorrowId.Set.t (** Utility exception *) exception ValueMatchFailure of updt_env_kind @@ -28,10 +19,10 @@ exception ValueMatchFailure of updt_env_kind (** Utility exception *) exception Distinct of string -type ctx_or_update = (C.eval_ctx, updt_env_kind) result +type ctx_or_update = (eval_ctx, updt_env_kind) result (** Union Find *) -module UnionFind = UF.Make (UF.StoreMap) +module UF = UnionFind.Make (UnionFind.StoreMap) (** A small utility - @@ -41,13 +32,13 @@ module UnionFind = UF.Make (UF.StoreMap) instance, [borrow_to_abs] maps to a *set* of ids). *) type abs_borrows_loans_maps = { - abs_ids : V.AbstractionId.id list; - abs_to_borrows : V.BorrowId.Set.t V.AbstractionId.Map.t; - abs_to_loans : V.BorrowId.Set.t V.AbstractionId.Map.t; - abs_to_borrows_loans : V.BorrowId.Set.t V.AbstractionId.Map.t; - borrow_to_abs : V.AbstractionId.Set.t V.BorrowId.Map.t; - loan_to_abs : V.AbstractionId.Set.t V.BorrowId.Map.t; - borrow_loan_to_abs : V.AbstractionId.Set.t V.BorrowId.Map.t; + abs_ids : AbstractionId.id list; + abs_to_borrows : BorrowId.Set.t AbstractionId.Map.t; + abs_to_loans : BorrowId.Set.t AbstractionId.Map.t; + abs_to_borrows_loans : BorrowId.Set.t AbstractionId.Map.t; + borrow_to_abs : AbstractionId.Set.t BorrowId.Map.t; + loan_to_abs : AbstractionId.Set.t BorrowId.Map.t; + borrow_loan_to_abs : AbstractionId.Set.t BorrowId.Map.t; } (** See {!InterpreterLoopsMatchCtxs.MakeMatcher} and {!InterpreterLoopsCore.Matcher}. @@ -56,14 +47,14 @@ type abs_borrows_loans_maps = { {!InterpreterLoopsMatchCtxs.MakeMatcher} functor. *) module type PrimMatcher = sig - val match_etys : T.ety -> T.ety -> T.ety - val match_rtys : T.rty -> T.rty -> T.rty + val match_etys : ety -> ety -> ety + val match_rtys : rty -> rty -> rty (** The input primitive values are not equal *) - val match_distinct_literals : T.ety -> V.literal -> V.literal -> V.typed_value + val match_distinct_literals : ety -> literal -> literal -> typed_value (** The input ADTs don't have the same variant *) - val match_distinct_adts : T.ety -> V.adt_value -> V.adt_value -> V.typed_value + val match_distinct_adts : ety -> adt_value -> adt_value -> typed_value (** The meta-value is the result of a match. @@ -76,11 +67,11 @@ module type PrimMatcher = sig calling the match function. *) val match_shared_borrows : - (V.typed_value -> V.typed_value -> V.typed_value) -> - T.ety -> - V.borrow_id -> - V.borrow_id -> - V.borrow_id + (typed_value -> typed_value -> typed_value) -> + ety -> + borrow_id -> + borrow_id -> + borrow_id (** The input parameters are: - [ty] @@ -91,13 +82,13 @@ module type PrimMatcher = sig - [bv]: the result of matching [bv0] with [bv1] *) val match_mut_borrows : - T.ety -> - V.borrow_id -> - V.typed_value -> - V.borrow_id -> - V.typed_value -> - V.typed_value -> - V.borrow_id * V.typed_value + ety -> + borrow_id -> + typed_value -> + borrow_id -> + typed_value -> + typed_value -> + borrow_id * typed_value (** Parameters: [ty] @@ -106,17 +97,16 @@ module type PrimMatcher = sig [v]: the result of matching the shared values coming from the two loans *) val match_shared_loans : - T.ety -> - V.loan_id_set -> - V.loan_id_set -> - V.typed_value -> - V.loan_id_set * V.typed_value + ety -> + loan_id_set -> + loan_id_set -> + typed_value -> + loan_id_set * typed_value - val match_mut_loans : T.ety -> V.loan_id -> V.loan_id -> V.loan_id + val match_mut_loans : ety -> loan_id -> loan_id -> loan_id (** There are no constraints on the input symbolic values *) - val match_symbolic_values : - V.symbolic_value -> V.symbolic_value -> V.symbolic_value + val match_symbolic_values : symbolic_value -> symbolic_value -> symbolic_value (** Match a symbolic value with a value which is not symbolic. @@ -126,7 +116,7 @@ module type PrimMatcher = sig end loans in one of the two environments). *) val match_symbolic_with_other : - bool -> V.symbolic_value -> V.typed_value -> V.typed_value + bool -> symbolic_value -> typed_value -> typed_value (** Match a bottom value with a value which is not bottom. @@ -135,11 +125,11 @@ module type PrimMatcher = sig is important when throwing exceptions, for instance when we need to end loans in one of the two environments). *) - val match_bottom_with_other : bool -> V.typed_value -> V.typed_value + val match_bottom_with_other : bool -> typed_value -> typed_value (** The input ADTs don't have the same variant *) val match_distinct_aadts : - T.rty -> V.adt_avalue -> T.rty -> V.adt_avalue -> T.rty -> V.typed_avalue + rty -> adt_avalue -> rty -> adt_avalue -> rty -> typed_avalue (** Parameters: [ty0] @@ -149,7 +139,7 @@ module type PrimMatcher = sig [ty]: result of matching ty0 and ty1 *) val match_ashared_borrows : - T.rty -> V.borrow_id -> T.rty -> V.borrow_id -> T.rty -> V.typed_avalue + rty -> borrow_id -> rty -> borrow_id -> rty -> typed_avalue (** Parameters: [ty0] @@ -162,15 +152,15 @@ module type PrimMatcher = sig [av]: result of matching av0 and av1 *) val match_amut_borrows : - T.rty -> - V.borrow_id -> - V.typed_avalue -> - T.rty -> - V.borrow_id -> - V.typed_avalue -> - T.rty -> - V.typed_avalue -> - V.typed_avalue + rty -> + borrow_id -> + typed_avalue -> + rty -> + borrow_id -> + typed_avalue -> + rty -> + typed_avalue -> + typed_avalue (** Parameters: [ty0] @@ -186,18 +176,18 @@ module type PrimMatcher = sig [av]: result of matching av0 and av1 *) val match_ashared_loans : - T.rty -> - V.loan_id_set -> - V.typed_value -> - V.typed_avalue -> - T.rty -> - V.loan_id_set -> - V.typed_value -> - V.typed_avalue -> - T.rty -> - V.typed_value -> - V.typed_avalue -> - V.typed_avalue + rty -> + loan_id_set -> + typed_value -> + typed_avalue -> + rty -> + loan_id_set -> + typed_value -> + typed_avalue -> + rty -> + typed_value -> + typed_avalue -> + typed_avalue (** Parameters: [ty0] @@ -210,20 +200,20 @@ module type PrimMatcher = sig [av]: result of matching av0 and av1 *) val match_amut_loans : - T.rty -> - V.borrow_id -> - V.typed_avalue -> - T.rty -> - V.borrow_id -> - V.typed_avalue -> - T.rty -> - V.typed_avalue -> - V.typed_avalue + rty -> + borrow_id -> + typed_avalue -> + rty -> + borrow_id -> + typed_avalue -> + rty -> + typed_avalue -> + typed_avalue (** Match two arbitrary avalues whose constructors don't match (this function is typically used to raise the proper exception). *) - val match_avalues : V.typed_avalue -> V.typed_avalue -> V.typed_avalue + val match_avalues : typed_avalue -> typed_avalue -> typed_avalue end module type Matcher = sig @@ -231,15 +221,14 @@ module type Matcher = sig Rem.: this function raises exceptions of type {!Aeneas.InterpreterLoopsCore.ValueMatchFailure}. *) - val match_typed_values : - C.eval_ctx -> V.typed_value -> V.typed_value -> V.typed_value + val match_typed_values : eval_ctx -> typed_value -> typed_value -> typed_value (** Match two avalues. Rem.: this function raises exceptions of type {!Aeneas.InterpreterLoopsCore.ValueMatchFailure}. *) val match_typed_avalues : - C.eval_ctx -> V.typed_avalue -> V.typed_avalue -> V.typed_avalue + eval_ctx -> typed_avalue -> typed_avalue -> typed_avalue end (** See {!InterpreterLoopsMatchCtxs.MakeCheckEquivMatcher} and @@ -252,78 +241,75 @@ module type MatchCheckEquivState = sig a source context with a target context. *) val check_equiv : bool - val ctx : C.eval_ctx - val rid_map : T.RegionId.InjSubst.t ref + val ctx : eval_ctx + val rid_map : RegionId.InjSubst.t ref (** Substitution for the loan and borrow ids - used only if [check_equiv] is true *) - val blid_map : V.BorrowId.InjSubst.t ref + val blid_map : BorrowId.InjSubst.t ref (** Substitution for the borrow ids - used only if [check_equiv] is false *) - val borrow_id_map : V.BorrowId.InjSubst.t ref + val borrow_id_map : BorrowId.InjSubst.t ref (** Substitution for the loans ids - used only if [check_equiv] is false *) - val loan_id_map : V.BorrowId.InjSubst.t ref + val loan_id_map : BorrowId.InjSubst.t ref - val sid_map : V.SymbolicValueId.InjSubst.t ref - val sid_to_value_map : V.typed_value V.SymbolicValueId.Map.t ref - val aid_map : V.AbstractionId.InjSubst.t ref - val lookup_shared_value_in_ctx0 : V.BorrowId.id -> V.typed_value - val lookup_shared_value_in_ctx1 : V.BorrowId.id -> V.typed_value + val sid_map : SymbolicValueId.InjSubst.t ref + val sid_to_value_map : typed_value SymbolicValueId.Map.t ref + val aid_map : AbstractionId.InjSubst.t ref + val lookup_shared_value_in_ctx0 : BorrowId.id -> typed_value + val lookup_shared_value_in_ctx1 : BorrowId.id -> typed_value end module type CheckEquivMatcher = sig include PrimMatcher - val match_aid : V.abstraction_id -> V.abstraction_id -> V.abstraction_id + val match_aid : abstraction_id -> abstraction_id -> abstraction_id val match_aidl : - V.abstraction_id list -> V.abstraction_id list -> V.abstraction_id list + abstraction_id list -> abstraction_id list -> abstraction_id list val match_aids : - V.abstraction_id_set -> V.abstraction_id_set -> V.abstraction_id_set - - val match_rid : V.region_id -> V.region_id -> V.region_id - val match_rids : V.region_id_set -> V.region_id_set -> V.region_id_set - val match_borrow_id : V.borrow_id -> V.borrow_id -> V.borrow_id - - val match_borrow_idl : - V.borrow_id list -> V.borrow_id list -> V.borrow_id list - - val match_borrow_ids : V.borrow_id_set -> V.borrow_id_set -> V.borrow_id_set - val match_loan_id : V.loan_id -> V.loan_id -> V.loan_id - val match_loan_idl : V.loan_id list -> V.loan_id list -> V.loan_id list - val match_loan_ids : V.loan_id_set -> V.loan_id_set -> V.loan_id_set + abstraction_id_set -> abstraction_id_set -> abstraction_id_set + + val match_rid : region_id -> region_id -> region_id + val match_rids : region_id_set -> region_id_set -> region_id_set + val match_borrow_id : borrow_id -> borrow_id -> borrow_id + val match_borrow_idl : borrow_id list -> borrow_id list -> borrow_id list + val match_borrow_ids : borrow_id_set -> borrow_id_set -> borrow_id_set + val match_loan_id : loan_id -> loan_id -> loan_id + val match_loan_idl : loan_id list -> loan_id list -> loan_id list + val match_loan_ids : loan_id_set -> loan_id_set -> loan_id_set end (** See {!InterpreterLoopsMatchCtxs.match_ctxs} *) type ids_maps = { - aid_map : V.AbstractionId.InjSubst.t; - blid_map : V.BorrowId.InjSubst.t; + aid_map : AbstractionId.InjSubst.t; + blid_map : BorrowId.InjSubst.t; (** Substitution for the loan and borrow ids *) - borrow_id_map : V.BorrowId.InjSubst.t; (** Substitution for the borrow ids *) - loan_id_map : V.BorrowId.InjSubst.t; (** Substitution for the loan ids *) - rid_map : T.RegionId.InjSubst.t; - sid_map : V.SymbolicValueId.InjSubst.t; - sid_to_value_map : V.typed_value V.SymbolicValueId.Map.t; + borrow_id_map : BorrowId.InjSubst.t; (** Substitution for the borrow ids *) + loan_id_map : BorrowId.InjSubst.t; (** Substitution for the loan ids *) + rid_map : RegionId.InjSubst.t; + sid_map : SymbolicValueId.InjSubst.t; + sid_to_value_map : typed_value SymbolicValueId.Map.t; } [@@deriving show] type borrow_loan_corresp = { - borrow_to_loan_id_map : V.BorrowId.InjSubst.t; - loan_to_borrow_id_map : V.BorrowId.InjSubst.t; + borrow_to_loan_id_map : BorrowId.InjSubst.t; + loan_to_borrow_id_map : BorrowId.InjSubst.t; } [@@deriving show] (* Very annoying: functors only take modules as inputs... *) module type MatchJoinState = sig (** The current context *) - val ctx : C.eval_ctx + val ctx : eval_ctx (** The current loop *) - val loop_id : V.LoopId.id + val loop_id : LoopId.id (** The abstractions introduced when performing the matches *) - val nabs : V.abs list ref + val nabs : abs list ref end (** Split an environment between the fixed abstractions, values, etc. and @@ -331,36 +317,36 @@ end Returns: (fixed, new abs, new dummies) *) -let ctx_split_fixed_new (fixed_ids : ids_sets) (ctx : C.eval_ctx) : - C.env * V.abs list * V.typed_value list = - let is_fresh_did (id : C.DummyVarId.id) : bool = - not (C.DummyVarId.Set.mem id fixed_ids.dids) +let ctx_split_fixed_new (fixed_ids : ids_sets) (ctx : eval_ctx) : + env * abs list * typed_value list = + let is_fresh_did (id : DummyVarId.id) : bool = + not (DummyVarId.Set.mem id fixed_ids.dids) in - let is_fresh_abs_id (id : V.AbstractionId.id) : bool = - not (V.AbstractionId.Set.mem id fixed_ids.aids) + let is_fresh_abs_id (id : AbstractionId.id) : bool = + not (AbstractionId.Set.mem id fixed_ids.aids) in (* Filter the new abstractions and dummy variables (there shouldn't be any new dummy variable though) in the target context *) - let is_fresh (ee : C.env_elem) : bool = + let is_fresh (ee : env_elem) : bool = match ee with - | C.EBinding (BVar _, _) | C.EFrame -> false - | C.EBinding (BDummy bv, _) -> is_fresh_did bv - | C.EAbs abs -> is_fresh_abs_id abs.abs_id + | EBinding (BVar _, _) | EFrame -> false + | EBinding (BDummy bv, _) -> is_fresh_did bv + | EAbs abs -> is_fresh_abs_id abs.abs_id in let new_eel, filt_env = List.partition is_fresh ctx.env in - let is_abs ee = match ee with C.EAbs _ -> true | _ -> false in + let is_abs ee = match ee with EAbs _ -> true | _ -> false in let new_absl, new_dummyl = List.partition is_abs new_eel in let new_absl = List.map (fun ee -> - match ee with C.EAbs abs -> abs | _ -> raise (Failure "Unreachable")) + match ee with EAbs abs -> abs | _ -> raise (Failure "Unreachable")) new_absl in let new_dummyl = List.map (fun ee -> match ee with - | C.EBinding (BDummy _, v) -> v + | EBinding (BDummy _, v) -> v | _ -> raise (Failure "Unreachable")) new_dummyl in @@ -370,7 +356,7 @@ let ids_sets_empty_borrows_loans (ids : ids_sets) : ids_sets = let { aids; blids = _; borrow_ids = _; loan_ids = _; dids; rids; sids } = ids in - let empty = V.BorrowId.Set.empty in + let empty = BorrowId.Set.empty in let ids = { aids; diff --git a/compiler/InterpreterLoopsFixedPoint.ml b/compiler/InterpreterLoopsFixedPoint.ml index a35b2716..3cc0a5f0 100644 --- a/compiler/InterpreterLoopsFixedPoint.ml +++ b/compiler/InterpreterLoopsFixedPoint.ml @@ -1,14 +1,8 @@ -module T = Types -module PV = PrimitiveValues -module V = Values -module E = Expressions -module C = Contexts -module Subst = Substitute -module A = LlbcAst -module L = Logging +open Types +open Values +open Contexts open TypesUtils open ValuesUtils -module Inv = Invariants module S = SynthesizeSymbolic open Cps open InterpreterUtils @@ -17,7 +11,7 @@ open InterpreterLoopsMatchCtxs open InterpreterLoopsJoinCtxs (** The local logger *) -let log = L.loops_fixed_point_log +let log = Logging.loops_fixed_point_log (** Reorder the loans and borrows in the fresh abstractions. @@ -26,17 +20,17 @@ let log = L.loops_fixed_point_log called typically after we merge abstractions together (see {!collapse_ctx} for instance). *) -let reorder_loans_borrows_in_fresh_abs (old_abs_ids : V.AbstractionId.Set.t) - (ctx : C.eval_ctx) : C.eval_ctx = - let reorder_in_fresh_abs (abs : V.abs) : V.abs = +let reorder_loans_borrows_in_fresh_abs (old_abs_ids : AbstractionId.Set.t) + (ctx : eval_ctx) : eval_ctx = + let reorder_in_fresh_abs (abs : abs) : abs = (* Split between the loans and borrows *) - let is_borrow (av : V.typed_avalue) : bool = - match av.V.value with + let is_borrow (av : typed_avalue) : bool = + match av.value with | ABorrow _ -> true | ALoan _ -> false | _ -> raise (Failure "Unexpected") in - let aborrows, aloans = List.partition is_borrow abs.V.avalues in + let aborrows, aloans = List.partition is_borrow abs.avalues in (* Reoder the borrows, and the loans. @@ -44,40 +38,40 @@ let reorder_loans_borrows_in_fresh_abs (old_abs_ids : V.AbstractionId.Set.t) and the borrows to find fixed points is simply to sort them by increasing order of id (taking the smallest id of a set of ids, in case of sets). *) - let get_borrow_id (av : V.typed_avalue) : V.BorrowId.id = - match av.V.value with - | V.ABorrow (V.AMutBorrow (bid, _) | V.ASharedBorrow bid) -> bid + let get_borrow_id (av : typed_avalue) : BorrowId.id = + match av.value with + | ABorrow (AMutBorrow (bid, _) | ASharedBorrow bid) -> bid | _ -> raise (Failure "Unexpected") in - let get_loan_id (av : V.typed_avalue) : V.BorrowId.id = - match av.V.value with - | V.ALoan (V.AMutLoan (lid, _)) -> lid - | V.ALoan (V.ASharedLoan (lids, _, _)) -> V.BorrowId.Set.min_elt lids + let get_loan_id (av : typed_avalue) : BorrowId.id = + match av.value with + | ALoan (AMutLoan (lid, _)) -> lid + | ALoan (ASharedLoan (lids, _, _)) -> BorrowId.Set.min_elt lids | _ -> raise (Failure "Unexpected") in (* We use ordered maps to reorder the borrows and loans *) - let reorder (get_bid : V.typed_avalue -> V.BorrowId.id) - (values : V.typed_avalue list) : V.typed_avalue list = + let reorder (get_bid : typed_avalue -> BorrowId.id) + (values : typed_avalue list) : typed_avalue list = List.map snd - (V.BorrowId.Map.bindings - (V.BorrowId.Map.of_list (List.map (fun v -> (get_bid v, v)) values))) + (BorrowId.Map.bindings + (BorrowId.Map.of_list (List.map (fun v -> (get_bid v, v)) values))) in let aborrows = reorder get_borrow_id aborrows in let aloans = reorder get_loan_id aloans in let avalues = List.append aborrows aloans in - { abs with V.avalues } + { abs with avalues } in - let reorder_in_abs (abs : V.abs) = - if V.AbstractionId.Set.mem abs.abs_id old_abs_ids then abs + let reorder_in_abs (abs : abs) = + if AbstractionId.Set.mem abs.abs_id old_abs_ids then abs else reorder_in_fresh_abs abs in - let env = C.env_map_abs reorder_in_abs ctx.env in + let env = env_map_abs reorder_in_abs ctx.env in - { ctx with C.env } + { ctx with env } -let prepare_ashared_loans (loop_id : V.LoopId.id option) : cm_fun = +let prepare_ashared_loans (loop_id : LoopId.id option) : cm_fun = fun cf ctx0 -> let ctx = ctx0 in (* Compute the set of borrows which appear in the abstractions, so that @@ -85,7 +79,7 @@ let prepare_ashared_loans (loop_id : V.LoopId.id option) : cm_fun = *) let absl = List.filter_map - (function C.EBinding _ | C.EFrame -> None | C.EAbs abs -> Some abs) + (function EBinding _ | EFrame -> None | EAbs abs -> Some abs) ctx.env in let absl_ids, absl_id_maps = compute_absl_ids absl in @@ -100,18 +94,18 @@ let prepare_ashared_loans (loop_id : V.LoopId.id option) : cm_fun = - the region ids found in the value and belonging to the set [rids] have been substituted with [nrid] *) - let mk_value_with_fresh_sids_no_shared_loans (rids : T.RegionId.Set.t) - (nrid : T.RegionId.id) (v : V.typed_value) : V.typed_value = + let mk_value_with_fresh_sids_no_shared_loans (rids : RegionId.Set.t) + (nrid : RegionId.id) (v : typed_value) : typed_value = (* Remove the shared loans *) let v = value_remove_shared_loans v in (* Substitute the symbolic values and the region *) - Subst.typed_value_subst_ids - (fun r -> if T.RegionId.Set.mem r rids then nrid else r) + Substitute.typed_value_subst_ids + (fun r -> if RegionId.Set.mem r rids then nrid else r) (fun x -> x) (fun x -> x) (fun id -> - let nid = C.fresh_symbolic_value_id () in - let sv = V.SymbolicValueId.Map.find id absl_id_maps.sids_to_values in + let nid = fresh_symbolic_value_id () in + let sv = SymbolicValueId.Map.find id absl_id_maps.sids_to_values in sid_subst := (nid, sv) :: !sid_subst; nid) (fun x -> x) @@ -142,13 +136,13 @@ let prepare_ashared_loans (loop_id : V.LoopId.id option) : cm_fun = abs'2 { SB l0, SL {l2} s2 } ]} *) - let push_abs_for_shared_value (abs : V.abs) (sv : V.typed_value) - (lid : V.BorrowId.id) : unit = + let push_abs_for_shared_value (abs : abs) (sv : typed_value) + (lid : BorrowId.id) : unit = (* Create a fresh borrow (for the reborrow) *) - let nlid = C.fresh_borrow_id () in + let nlid = fresh_borrow_id () in (* We need a fresh region for the new abstraction *) - let nrid = C.fresh_region_id () in + let nrid = fresh_region_id () in (* Prepare the shared value *) let nsv = mk_value_with_fresh_sids_no_shared_loans abs.regions nrid sv in @@ -157,47 +151,47 @@ let prepare_ashared_loans (loop_id : V.LoopId.id option) : cm_fun = borrow_substs := (lid, nlid) :: !borrow_substs; (* Rem.: the below sanity checks are not really necessary *) - assert (V.AbstractionId.Set.is_empty abs.parents); + assert (AbstractionId.Set.is_empty abs.parents); assert (abs.original_parents = []); - assert (T.RegionId.Set.is_empty abs.ancestors_regions); + assert (RegionId.Set.is_empty abs.ancestors_regions); (* Introduce the new abstraction for the shared values *) - assert (ty_no_regions sv.V.ty); - let rty = sv.V.ty in + assert (ty_no_regions sv.ty); + let rty = sv.ty in (* Create the shared loan child *) let child_rty = rty in let child_av = mk_aignored child_rty in (* Create the shared loan *) - let loan_rty = T.TRef (T.RVar nrid, rty, T.Shared) in + let loan_rty = TRef (RVar nrid, rty, RShared) in let loan_value = - V.ALoan (V.ASharedLoan (V.BorrowId.Set.singleton nlid, nsv, child_av)) + ALoan (ASharedLoan (BorrowId.Set.singleton nlid, nsv, child_av)) in let loan_value = mk_typed_avalue loan_rty loan_value in (* Create the shared borrow *) let borrow_rty = loan_rty in - let borrow_value = V.ABorrow (V.ASharedBorrow lid) in + let borrow_value = ABorrow (ASharedBorrow lid) in let borrow_value = mk_typed_avalue borrow_rty borrow_value in (* Create the abstraction *) let avalues = [ borrow_value; loan_value ] in - let kind = + let kind : abs_kind = match loop_id with - | Some loop_id -> V.Loop (loop_id, None, V.LoopSynthInput) - | None -> V.Identity + | Some loop_id -> Loop (loop_id, None, LoopSynthInput) + | None -> Identity in let can_end = true in let fresh_abs = { - V.abs_id = C.fresh_abstraction_id (); + abs_id = fresh_abstraction_id (); kind; can_end; - parents = V.AbstractionId.Set.empty; + parents = AbstractionId.Set.empty; original_parents = []; - regions = T.RegionId.Set.singleton nrid; - ancestors_regions = T.RegionId.Set.empty; + regions = RegionId.Set.singleton nrid; + ancestors_regions = RegionId.Set.empty; avalues; } in @@ -210,22 +204,22 @@ let prepare_ashared_loans (loop_id : V.LoopId.id option) : cm_fun = We simply explore the context and call {!push_abs_for_shared_value} when necessary. *) - let collect_shared_values_in_abs (abs : V.abs) : unit = - let collect_shared_value lids (sv : V.typed_value) = + let collect_shared_values_in_abs (abs : abs) : unit = + let collect_shared_value lids (sv : typed_value) = (* Sanity check: we don't support nested borrows for now *) - assert (not (value_has_borrows ctx sv.V.value)); + assert (not (value_has_borrows ctx sv.value)); (* Filter the loan ids whose corresponding borrows appear in abstractions (see the documentation of the function) *) - let lids = V.BorrowId.Set.diff lids abs_borrow_ids in + let lids = BorrowId.Set.diff lids abs_borrow_ids in (* Generate fresh borrows and values *) - V.BorrowId.Set.iter (push_abs_for_shared_value abs sv) lids + BorrowId.Set.iter (push_abs_for_shared_value abs sv) lids in let visit_avalue = object - inherit [_] V.iter_typed_avalue as super + inherit [_] iter_typed_avalue as super method! visit_VSharedLoan env lids sv = collect_shared_value lids sv; @@ -253,7 +247,7 @@ let prepare_ashared_loans (loop_id : V.LoopId.id option) : cm_fun = in List.iter (visit_avalue#visit_typed_avalue None) abs.avalues in - C.env_iter_abs collect_shared_values_in_abs ctx.env; + env_iter_abs collect_shared_values_in_abs ctx.env; (* Update the borrow ids in the environment. @@ -287,16 +281,14 @@ let prepare_ashared_loans (loop_id : V.LoopId.id option) : cm_fun = ]} *) let env = - let bmap = V.BorrowId.Map.of_list !borrow_substs in + let bmap = BorrowId.Map.of_list !borrow_substs in let bsusbt bid = - match V.BorrowId.Map.find_opt bid bmap with - | None -> bid - | Some bid -> bid + match BorrowId.Map.find_opt bid bmap with None -> bid | Some bid -> bid in let visitor = object - inherit [_] C.map_env + inherit [_] map_env method! visit_borrow_id _ bid = bsusbt bid end in @@ -304,7 +296,7 @@ let prepare_ashared_loans (loop_id : V.LoopId.id option) : cm_fun = in (* Add the abstractions *) - let fresh_absl = List.map (fun abs -> C.EAbs abs) !fresh_absl in + let fresh_absl = List.map (fun abs -> EAbs abs) !fresh_absl in let env = List.append fresh_absl env in let ctx = { ctx with env } in @@ -320,18 +312,18 @@ let prepare_ashared_loans (loop_id : V.LoopId.id option) : cm_fun = (fun e (sid, v) -> let v = mk_typed_value_from_symbolic_value v in let sv = - V.SymbolicValueId.Map.find sid new_ctx_ids_map.sids_to_values + SymbolicValueId.Map.find sid new_ctx_ids_map.sids_to_values in SymbolicAst.IntroSymbolic (ctx, None, sv, VaSingleValue v, e)) e !sid_subst) -let prepare_ashared_loans_no_synth (loop_id : V.LoopId.id) (ctx : C.eval_ctx) : - C.eval_ctx = +let prepare_ashared_loans_no_synth (loop_id : LoopId.id) (ctx : eval_ctx) : + eval_ctx = get_cf_ctx_no_synth (prepare_ashared_loans (Some loop_id)) ctx -let compute_loop_entry_fixed_point (config : C.config) (loop_id : V.LoopId.id) - (eval_loop_body : st_cm_fun) (ctx0 : C.eval_ctx) : - C.eval_ctx * ids_sets * V.abs T.RegionGroupId.Map.t = +let compute_loop_entry_fixed_point (config : config) (loop_id : LoopId.id) + (eval_loop_body : st_cm_fun) (ctx0 : eval_ctx) : + eval_ctx * ids_sets * abs RegionGroupId.Map.t = (* The continuation for when we exit the loop - we register the environments upon loop *reentry*, and synthesize nothing by returning [None] @@ -384,7 +376,7 @@ let compute_loop_entry_fixed_point (config : C.config) (loop_id : V.LoopId.id) (* Join the contexts at the loop entry - ctx1 is the current joined context (the context at the loop entry, after we called {!prepare_ashared_loans}, if this is the first iteration) *) - let join_ctxs (ctx1 : C.eval_ctx) : C.eval_ctx = + let join_ctxs (ctx1 : eval_ctx) : eval_ctx = (* If this is the first iteration, end the borrows/loans/abs which appear in ctx1 and not in the other contexts, then compute the set of fixed ids. This means those borrows/loans have to end @@ -395,8 +387,8 @@ let compute_loop_entry_fixed_point (config : C.config) (loop_id : V.LoopId.id) | None -> let old_ids, _ = compute_context_ids ctx1 in let new_ids, _ = compute_contexts_ids !ctxs in - let blids = V.BorrowId.Set.diff old_ids.blids new_ids.blids in - let aids = V.AbstractionId.Set.diff old_ids.aids new_ids.aids in + let blids = BorrowId.Set.diff old_ids.blids new_ids.blids in + let aids = AbstractionId.Set.diff old_ids.aids new_ids.aids in (* End those borrows and abstractions *) let end_borrows_abs blids aids ctx = let ctx = @@ -431,14 +423,14 @@ let compute_loop_entry_fixed_point (config : C.config) (loop_id : V.LoopId.id) (* Compute the set of fixed ids - for the symbolic ids, we compute the intersection of ids between the original environment and the list of new environments *) - let compute_fixed_ids (ctxl : C.eval_ctx list) : ids_sets = + let compute_fixed_ids (ctxl : eval_ctx list) : ids_sets = let fixed_ids, _ = compute_context_ids ctx0 in let { aids; blids; borrow_ids; loan_ids; dids; rids; sids } = fixed_ids in let sids = ref sids in List.iter (fun ctx -> let fixed_ids, _ = compute_context_ids ctx in - sids := V.SymbolicValueId.Set.inter !sids fixed_ids.sids) + sids := SymbolicValueId.Set.inter !sids fixed_ids.sids) ctxl; let sids = !sids in let fixed_ids = { aids; blids; borrow_ids; loan_ids; dids; rids; sids } in @@ -447,7 +439,7 @@ let compute_loop_entry_fixed_point (config : C.config) (loop_id : V.LoopId.id) (* Check if two contexts are equivalent - modulo alpha conversion on the existentially quantified borrows/abstractions/symbolic values. *) - let equiv_ctxs (ctx1 : C.eval_ctx) (ctx2 : C.eval_ctx) : bool = + let equiv_ctxs (ctx1 : eval_ctx) (ctx2 : eval_ctx) : bool = let fixed_ids = compute_fixed_ids [ ctx1; ctx2 ] in let check_equivalent = true in let lookup_shared_value _ = raise (Failure "Unreachable") in @@ -456,8 +448,7 @@ let compute_loop_entry_fixed_point (config : C.config) (loop_id : V.LoopId.id) lookup_shared_value ctx1 ctx2) in let max_num_iter = Config.loop_fixed_point_max_num_iters in - let rec compute_fixed_point (ctx : C.eval_ctx) (i0 : int) (i : int) : - C.eval_ctx = + let rec compute_fixed_point (ctx : eval_ctx) (i0 : int) (i : int) : eval_ctx = if i = 0 then raise (Failure @@ -502,17 +493,17 @@ let compute_loop_entry_fixed_point (config : C.config) (loop_id : V.LoopId.id) *) let fp, rg_to_abs = (* List the loop abstractions in the fixed-point *) - let fp_aids, add_aid, _mem_aid = V.AbstractionId.Set.mk_stateful_set () in + let fp_aids, add_aid, _mem_aid = AbstractionId.Set.mk_stateful_set () in let list_loop_abstractions = object - inherit [_] C.map_eval_ctx + inherit [_] map_eval_ctx method! visit_abs _ abs = match abs.kind with | Loop (loop_id', _, kind) -> assert (loop_id' = loop_id); - assert (kind = V.LoopSynthInput); + assert (kind = LoopSynthInput); (* The abstractions introduced so far should be endable *) assert (abs.can_end = true); add_aid abs.abs_id; @@ -529,15 +520,14 @@ let compute_loop_entry_fixed_point (config : C.config) (loop_id : V.LoopId.id) * * [fp_ended_aids] links region groups to sets of ended abstractions. *) - let fp_ended_aids = ref T.RegionGroupId.Map.empty in - let add_ended_aids (rg_id : T.RegionGroupId.id) - (aids : V.AbstractionId.Set.t) : unit = - match T.RegionGroupId.Map.find_opt rg_id !fp_ended_aids with - | None -> - fp_ended_aids := T.RegionGroupId.Map.add rg_id aids !fp_ended_aids + let fp_ended_aids = ref RegionGroupId.Map.empty in + let add_ended_aids (rg_id : RegionGroupId.id) (aids : AbstractionId.Set.t) : + unit = + match RegionGroupId.Map.find_opt rg_id !fp_ended_aids with + | None -> fp_ended_aids := RegionGroupId.Map.add rg_id aids !fp_ended_aids | Some aids' -> - let aids = V.AbstractionId.Set.union aids aids' in - fp_ended_aids := T.RegionGroupId.Map.add rg_id aids !fp_ended_aids + let aids = AbstractionId.Set.union aids aids' in + fp_ended_aids := RegionGroupId.Map.add rg_id aids !fp_ended_aids in let cf_loop : st_m_fun = fun res ctx -> @@ -566,20 +556,20 @@ let compute_loop_entry_fixed_point (config : C.config) (loop_id : V.LoopId.id) abstractions should have been introduced in a specific order (and we check that it is indeed the case) *) let abs_id = - V.AbstractionId.of_int (T.RegionGroupId.to_int rg_id) + AbstractionId.of_int (RegionGroupId.to_int rg_id) in (* By default, the [SynthInput] abs can't end *) - let ctx = C.ctx_set_abs_can_end ctx abs_id true in + let ctx = ctx_set_abs_can_end ctx abs_id true in assert ( - let abs = C.ctx_lookup_abs ctx abs_id in - abs.kind = V.SynthInput rg_id); + let abs = ctx_lookup_abs ctx abs_id in + abs.kind = SynthInput rg_id); (* End this abstraction *) let ctx = InterpreterBorrows.end_abstraction_no_synth config abs_id ctx in (* Explore the context, and check which abstractions are not there anymore *) let ids, _ = compute_context_ids ctx in - let ended_ids = V.AbstractionId.Set.diff !fp_aids ids.aids in + let ended_ids = AbstractionId.Set.diff !fp_aids ids.aids in add_ended_aids rg_id ended_ids) ctx.region_groups in @@ -590,27 +580,27 @@ let compute_loop_entry_fixed_point (config : C.config) (loop_id : V.LoopId.id) (* Check that the sets of abstractions we need to end per region group are pairwise * disjoint *) - let aids_union = ref V.AbstractionId.Set.empty in + let aids_union = ref AbstractionId.Set.empty in let _ = - T.RegionGroupId.Map.iter + RegionGroupId.Map.iter (fun _ ids -> - assert (V.AbstractionId.Set.disjoint !aids_union ids); - aids_union := V.AbstractionId.Set.union ids !aids_union) + assert (AbstractionId.Set.disjoint !aids_union ids); + aids_union := AbstractionId.Set.union ids !aids_union) !fp_ended_aids in (* We also check that all the regions need to end - this is not necessary per se, but if it doesn't happen it is bizarre and worth investigating... *) - assert (V.AbstractionId.Set.equal !aids_union !fp_aids); + assert (AbstractionId.Set.equal !aids_union !fp_aids); (* Merge the abstractions which need to be merged, and compute the map from region id to abstraction id *) let fp = ref fp in - let rg_to_abs = ref T.RegionGroupId.Map.empty in + let rg_to_abs = ref RegionGroupId.Map.empty in let _ = - T.RegionGroupId.Map.iter + RegionGroupId.Map.iter (fun rg_id ids -> - let ids = V.AbstractionId.Set.elements ids in + let ids = AbstractionId.Set.elements ids in (* Retrieve the first id of the group *) match ids with | [] -> @@ -623,10 +613,12 @@ let compute_loop_entry_fixed_point (config : C.config) (loop_id : V.LoopId.id) | id0 :: ids -> let id0 = ref id0 in (* Add the proper region group into the abstraction *) - let abs_kind = V.Loop (loop_id, Some rg_id, V.LoopSynthInput) in - let abs = C.ctx_lookup_abs !fp !id0 in - let abs = { abs with V.kind = abs_kind } in - let fp', _ = C.ctx_subst_abs !fp !id0 abs in + let abs_kind : abs_kind = + Loop (loop_id, Some rg_id, LoopSynthInput) + in + let abs = ctx_lookup_abs !fp !id0 in + let abs = { abs with kind = abs_kind } in + let fp', _ = ctx_subst_abs !fp !id0 abs in fp := fp'; (* Merge all the abstractions into this one *) List.iter @@ -635,10 +627,8 @@ let compute_loop_entry_fixed_point (config : C.config) (loop_id : V.LoopId.id) log#ldebug (lazy ("compute_loop_entry_fixed_point: merge FP \ - abstraction: " - ^ V.AbstractionId.to_string id - ^ " into " - ^ V.AbstractionId.to_string !id0)); + abstraction: " ^ AbstractionId.to_string id ^ " into " + ^ AbstractionId.to_string !id0)); (* Note that we merge *into* [id0] *) let fp', id0' = merge_into_abstraction loop_id abs_kind false !fp id !id0 @@ -649,8 +639,8 @@ let compute_loop_entry_fixed_point (config : C.config) (loop_id : V.LoopId.id) with ValueMatchFailure _ -> raise (Failure "Unexpected")) ids; (* Register the mapping *) - let abs = C.ctx_lookup_abs !fp !id0 in - rg_to_abs := T.RegionGroupId.Map.add_strict rg_id abs !rg_to_abs) + let abs = ctx_lookup_abs !fp !id0 in + rg_to_abs := RegionGroupId.Map.add_strict rg_id abs !rg_to_abs) !fp_ended_aids in let rg_to_abs = !rg_to_abs in @@ -674,15 +664,15 @@ let compute_loop_entry_fixed_point (config : C.config) (loop_id : V.LoopId.id) *) let update_loop_abstractions (remove_rg_id : bool) = object - inherit [_] C.map_eval_ctx + inherit [_] map_eval_ctx method! visit_abs _ abs = match abs.kind with | Loop (loop_id', _, kind) -> assert (loop_id' = loop_id); - assert (kind = V.LoopSynthInput); - let kind = - if remove_rg_id then V.Loop (loop_id, None, V.LoopSynthInput) + assert (kind = LoopSynthInput); + let kind : abs_kind = + if remove_rg_id then Loop (loop_id, None, LoopSynthInput) else abs.kind in { abs with can_end = remove_rg_id; kind } @@ -715,7 +705,7 @@ let compute_loop_entry_fixed_point (config : C.config) (loop_id : V.LoopId.id) (fp, fixed_ids, rg_to_abs) let compute_fixed_point_id_correspondance (fixed_ids : ids_sets) - (src_ctx : C.eval_ctx) (tgt_ctx : C.eval_ctx) : borrow_loan_corresp = + (src_ctx : eval_ctx) (tgt_ctx : eval_ctx) : borrow_loan_corresp = log#ldebug (lazy ("compute_fixed_point_id_correspondance:\n\n- fixed_ids:\n" @@ -741,7 +731,7 @@ let compute_fixed_point_id_correspondance (fixed_ids : ids_sets) let check_equiv = false in let fixed_ids = ids_sets_empty_borrows_loans fixed_ids in let open InterpreterBorrowsCore in - let lookup_shared_loan lid ctx : V.typed_value = + let lookup_shared_loan lid ctx : typed_value = match snd (lookup_loan ek_all lid ctx) with | Concrete (VSharedLoan (_, v)) -> v | Abstract (ASharedLoan (_, v, _)) -> v @@ -760,10 +750,10 @@ let compute_fixed_point_id_correspondance (fixed_ids : ids_sets) ^ show_ids_maps maps ^ "\n\n")); let src_to_tgt_borrow_map = - V.BorrowId.Map.of_list + BorrowId.Map.of_list (List.map (fun (x, y) -> (y, x)) - (V.BorrowId.InjSubst.bindings maps.borrow_id_map)) + (BorrowId.InjSubst.bindings maps.borrow_id_map)) in (* Sanity check: for every abstraction, the target loans and borrows are mapped @@ -800,12 +790,12 @@ let compute_fixed_point_id_correspondance (fixed_ids : ids_sets) let ids, _ = compute_abs_ids abs in (* Map the *loan* ids (we just match the corresponding *loans* ) *) let loan_ids = - V.BorrowId.Set.map - (fun x -> V.BorrowId.InjSubst.find x maps.borrow_id_map) + BorrowId.Set.map + (fun x -> BorrowId.InjSubst.find x maps.borrow_id_map) ids.loan_ids in (* Check that the loan and borrows are related *) - assert (V.BorrowId.Set.equal ids.borrow_ids loan_ids)) + assert (BorrowId.Set.equal ids.borrow_ids loan_ids)) new_absl; (* For every target abstraction (going back to the [list_nth_mut] example, @@ -819,27 +809,27 @@ let compute_fixed_point_id_correspondance (fixed_ids : ids_sets) if it actually corresponds to a borrows introduced when decomposing the abstractions to move the shared values out of the source context abstractions. *) - let tgt_borrow_to_loan = ref V.BorrowId.InjSubst.empty in + let tgt_borrow_to_loan = ref BorrowId.InjSubst.empty in let visit_tgt = object - inherit [_] V.iter_abs + inherit [_] iter_abs method! visit_borrow_id _ id = (* Find the target borrow *) - let tgt_borrow_id = V.BorrowId.Map.find id src_to_tgt_borrow_map in + let tgt_borrow_id = BorrowId.Map.find id src_to_tgt_borrow_map in (* Update the map *) tgt_borrow_to_loan := - V.BorrowId.InjSubst.add id tgt_borrow_id !tgt_borrow_to_loan + BorrowId.InjSubst.add id tgt_borrow_id !tgt_borrow_to_loan end in List.iter (visit_tgt#visit_abs ()) new_absl; (* Compute the map from loan to borrows *) let tgt_loan_to_borrow = - V.BorrowId.InjSubst.of_list + BorrowId.InjSubst.of_list (List.map (fun (x, y) -> (y, x)) - (V.BorrowId.InjSubst.bindings !tgt_borrow_to_loan)) + (BorrowId.InjSubst.bindings !tgt_borrow_to_loan)) in (* Return *) @@ -848,11 +838,11 @@ let compute_fixed_point_id_correspondance (fixed_ids : ids_sets) loan_to_borrow_id_map = tgt_loan_to_borrow; } -let compute_fp_ctx_symbolic_values (ctx : C.eval_ctx) (fp_ctx : C.eval_ctx) : - V.SymbolicValueId.Set.t * V.symbolic_value list = +let compute_fp_ctx_symbolic_values (ctx : eval_ctx) (fp_ctx : eval_ctx) : + SymbolicValueId.Set.t * symbolic_value list = let old_ids, _ = compute_context_ids ctx in let fp_ids, fp_ids_maps = compute_context_ids fp_ctx in - let fresh_sids = V.SymbolicValueId.Set.diff fp_ids.sids old_ids.sids in + let fresh_sids = SymbolicValueId.Set.diff fp_ids.sids old_ids.sids in (* Compute the set of symbolic values which appear in shared values inside *fixed* abstractions: because we introduce fresh abstractions and reborrows @@ -863,10 +853,10 @@ let compute_fp_ctx_symbolic_values (ctx : C.eval_ctx) (fp_ctx : C.eval_ctx) : let shared_sids_in_fixed_abs = let fixed_absl = List.filter - (fun (ee : C.env_elem) -> + (fun (ee : env_elem) -> match ee with - | C.EBinding _ | C.EFrame -> false - | EAbs abs -> V.AbstractionId.Set.mem abs.abs_id old_ids.aids) + | EBinding _ | EFrame -> false + | EAbs abs -> AbstractionId.Set.mem abs.abs_id old_ids.aids) ctx.env in @@ -876,17 +866,17 @@ let compute_fp_ctx_symbolic_values (ctx : C.eval_ctx) (fp_ctx : C.eval_ctx) : shared values. We prefer to be more general, in prevision of later changes. *) - let sids = ref V.SymbolicValueId.Set.empty in + let sids = ref SymbolicValueId.Set.empty in let visitor = object (self) - inherit [_] C.iter_env + inherit [_] iter_env method! visit_ASharedLoan inside_shared _ sv child_av = self#visit_typed_value true sv; self#visit_typed_avalue inside_shared child_av method! visit_symbolic_value_id inside_shared sid = - if inside_shared then sids := V.SymbolicValueId.Set.add sid !sids + if inside_shared then sids := SymbolicValueId.Set.add sid !sids end in visitor#visit_env false fixed_absl; @@ -900,15 +890,14 @@ let compute_fp_ctx_symbolic_values (ctx : C.eval_ctx) (fp_ctx : C.eval_ctx) : log#ldebug (lazy ("compute_fp_ctx_symbolic_values:" ^ "\n- shared_sids_in_fixed_abs:" - ^ V.SymbolicValueId.Set.show shared_sids_in_fixed_abs + ^ SymbolicValueId.Set.show shared_sids_in_fixed_abs ^ "\n- all_sids_to_values: " - ^ V.SymbolicValueId.Map.show (symbolic_value_to_string ctx) sids_to_values + ^ SymbolicValueId.Map.show (symbolic_value_to_string ctx) sids_to_values ^ "\n")); let sids_to_values = - V.SymbolicValueId.Map.filter - (fun sid _ -> - not (V.SymbolicValueId.Set.mem sid shared_sids_in_fixed_abs)) + SymbolicValueId.Map.filter + (fun sid _ -> not (SymbolicValueId.Set.mem sid shared_sids_in_fixed_abs)) sids_to_values in @@ -919,12 +908,12 @@ let compute_fp_ctx_symbolic_values (ctx : C.eval_ctx) (fp_ctx : C.eval_ctx) : variable [x] which appears before [y] are listed first, for instance. *) let input_svalues = - let found_sids = ref V.SymbolicValueId.Set.empty in + let found_sids = ref SymbolicValueId.Set.empty in let ordered_sids = ref [] in let visitor = object (self) - inherit [_] C.iter_env + inherit [_] iter_env (** We lookup the shared values *) method! visit_VSharedBorrow env bid = @@ -938,8 +927,8 @@ let compute_fp_ctx_symbolic_values (ctx : C.eval_ctx) (fp_ctx : C.eval_ctx) : self#visit_typed_value env v method! visit_symbolic_value_id _ id = - if not (V.SymbolicValueId.Set.mem id !found_sids) then ( - found_sids := V.SymbolicValueId.Set.add id !found_sids; + if not (SymbolicValueId.Set.mem id !found_sids) then ( + found_sids := SymbolicValueId.Set.add id !found_sids; ordered_sids := id :: !ordered_sids) end in @@ -947,7 +936,7 @@ let compute_fp_ctx_symbolic_values (ctx : C.eval_ctx) (fp_ctx : C.eval_ctx) : List.iter (visitor#visit_env_elem ()) (List.rev fp_ctx.env); List.filter_map - (fun id -> V.SymbolicValueId.Map.find_opt id sids_to_values) + (fun id -> SymbolicValueId.Map.find_opt id sids_to_values) (List.rev !ordered_sids) in @@ -958,7 +947,7 @@ let compute_fp_ctx_symbolic_values (ctx : C.eval_ctx) (fp_ctx : C.eval_ctx) : ^ "\n- fixed point:\n" ^ eval_ctx_to_string_no_filter fp_ctx ^ "\n- fresh_sids: " - ^ V.SymbolicValueId.Set.show fresh_sids + ^ SymbolicValueId.Set.show fresh_sids ^ "\n- input_svalues: " ^ Print.list_to_string (symbolic_value_to_string ctx) input_svalues ^ "\n\n")); diff --git a/compiler/InterpreterLoopsFixedPoint.mli b/compiler/InterpreterLoopsFixedPoint.mli index cb03bc9e..65a76359 100644 --- a/compiler/InterpreterLoopsFixedPoint.mli +++ b/compiler/InterpreterLoopsFixedPoint.mli @@ -1,13 +1,5 @@ -module T = Types -module PV = PrimitiveValues -module V = Values -module E = Expressions -module C = Contexts -module Subst = Substitute -module A = LlbcAst -module L = Logging -module Inv = Invariants -module S = SynthesizeSymbolic +open Values +open Contexts open InterpreterUtils open InterpreterLoopsCore @@ -56,7 +48,7 @@ open InterpreterLoopsCore we only introduce a fresh abstraction for [l1]. *) -val prepare_ashared_loans : V.loop_id option -> Cps.cm_fun +val prepare_ashared_loans : loop_id option -> Cps.cm_fun (** Compute a fixed-point for the context at the entry of the loop. We also return: @@ -71,11 +63,11 @@ val prepare_ashared_loans : V.loop_id option -> Cps.cm_fun the values which are read or modified (some symbolic values may be ignored). *) val compute_loop_entry_fixed_point : - C.config -> - V.loop_id -> + config -> + loop_id -> Cps.st_cm_fun -> - C.eval_ctx -> - C.eval_ctx * ids_sets * V.abs SymbolicAst.region_group_id_map + eval_ctx -> + eval_ctx * ids_sets * abs SymbolicAst.region_group_id_map (** For the abstractions in the fixed point, compute the correspondance between the borrows ids and the loans ids, if we want to introduce equivalent @@ -154,7 +146,7 @@ val compute_loop_entry_fixed_point : through the loan [l1] is actually the value which has to be given back to [l0]. *) val compute_fixed_point_id_correspondance : - ids_sets -> C.eval_ctx -> C.eval_ctx -> borrow_loan_corresp + ids_sets -> eval_ctx -> eval_ctx -> borrow_loan_corresp (** Compute the set of "quantified" symbolic value ids in a fixed-point context. @@ -163,4 +155,4 @@ val compute_fixed_point_id_correspondance : - the list of input symbolic values *) val compute_fp_ctx_symbolic_values : - C.eval_ctx -> C.eval_ctx -> V.symbolic_value_id_set * V.symbolic_value list + eval_ctx -> eval_ctx -> symbolic_value_id_set * symbolic_value list diff --git a/compiler/InterpreterLoopsJoinCtxs.ml b/compiler/InterpreterLoopsJoinCtxs.ml index 654ee21b..4cc74aae 100644 --- a/compiler/InterpreterLoopsJoinCtxs.ml +++ b/compiler/InterpreterLoopsJoinCtxs.ml @@ -1,23 +1,15 @@ -module T = Types -module PV = PrimitiveValues -module V = Values -module E = Expressions -module C = Contexts -module Subst = Substitute -module A = LlbcAst -module L = Logging +open Types +open Values +open Contexts open TypesUtils open ValuesUtils -module Inv = Invariants -module S = SynthesizeSymbolic -module UF = UnionFind open InterpreterUtils open InterpreterBorrows open InterpreterLoopsCore open InterpreterLoopsMatchCtxs (** The local logger *) -let log = L.loops_join_ctxs_log +let log = Logging.loops_join_ctxs_log (** Reorder the loans and borrows in the fresh abstractions. @@ -26,17 +18,17 @@ let log = L.loops_join_ctxs_log called typically after we merge abstractions together (see {!collapse_ctx} for instance). *) -let reorder_loans_borrows_in_fresh_abs (old_abs_ids : V.AbstractionId.Set.t) - (ctx : C.eval_ctx) : C.eval_ctx = - let reorder_in_fresh_abs (abs : V.abs) : V.abs = +let reorder_loans_borrows_in_fresh_abs (old_abs_ids : AbstractionId.Set.t) + (ctx : eval_ctx) : eval_ctx = + let reorder_in_fresh_abs (abs : abs) : abs = (* Split between the loans and borrows *) - let is_borrow (av : V.typed_avalue) : bool = - match av.V.value with + let is_borrow (av : typed_avalue) : bool = + match av.value with | ABorrow _ -> true | ALoan _ -> false | _ -> raise (Failure "Unexpected") in - let aborrows, aloans = List.partition is_borrow abs.V.avalues in + let aborrows, aloans = List.partition is_borrow abs.avalues in (* Reoder the borrows, and the loans. @@ -44,38 +36,38 @@ let reorder_loans_borrows_in_fresh_abs (old_abs_ids : V.AbstractionId.Set.t) and the borrows to find fixed points is simply to sort them by increasing order of id (taking the smallest id of a set of ids, in case of sets). *) - let get_borrow_id (av : V.typed_avalue) : V.BorrowId.id = - match av.V.value with - | V.ABorrow (V.AMutBorrow (bid, _) | V.ASharedBorrow bid) -> bid + let get_borrow_id (av : typed_avalue) : BorrowId.id = + match av.value with + | ABorrow (AMutBorrow (bid, _) | ASharedBorrow bid) -> bid | _ -> raise (Failure "Unexpected") in - let get_loan_id (av : V.typed_avalue) : V.BorrowId.id = - match av.V.value with - | V.ALoan (V.AMutLoan (lid, _)) -> lid - | V.ALoan (V.ASharedLoan (lids, _, _)) -> V.BorrowId.Set.min_elt lids + let get_loan_id (av : typed_avalue) : BorrowId.id = + match av.value with + | ALoan (AMutLoan (lid, _)) -> lid + | ALoan (ASharedLoan (lids, _, _)) -> BorrowId.Set.min_elt lids | _ -> raise (Failure "Unexpected") in (* We use ordered maps to reorder the borrows and loans *) - let reorder (get_bid : V.typed_avalue -> V.BorrowId.id) - (values : V.typed_avalue list) : V.typed_avalue list = + let reorder (get_bid : typed_avalue -> BorrowId.id) + (values : typed_avalue list) : typed_avalue list = List.map snd - (V.BorrowId.Map.bindings - (V.BorrowId.Map.of_list (List.map (fun v -> (get_bid v, v)) values))) + (BorrowId.Map.bindings + (BorrowId.Map.of_list (List.map (fun v -> (get_bid v, v)) values))) in let aborrows = reorder get_borrow_id aborrows in let aloans = reorder get_loan_id aloans in let avalues = List.append aborrows aloans in - { abs with V.avalues } + { abs with avalues } in - let reorder_in_abs (abs : V.abs) = - if V.AbstractionId.Set.mem abs.abs_id old_abs_ids then abs + let reorder_in_abs (abs : abs) = + if AbstractionId.Set.mem abs.abs_id old_abs_ids then abs else reorder_in_fresh_abs abs in - let env = C.env_map_abs reorder_in_abs ctx.env in + let env = env_map_abs reorder_in_abs ctx.env in - { ctx with C.env } + { ctx with env } (** Collapse an environment. @@ -136,23 +128,23 @@ let reorder_loans_borrows_in_fresh_abs (old_abs_ids : V.AbstractionId.Set.t) This can happen when merging environments (note that such environments are not well-formed - they become well formed again after collapsing). *) -let collapse_ctx (loop_id : V.LoopId.id) +let collapse_ctx (loop_id : LoopId.id) (merge_funs : merge_duplicates_funcs option) (old_ids : ids_sets) - (ctx0 : C.eval_ctx) : C.eval_ctx = + (ctx0 : eval_ctx) : eval_ctx = (* Debug *) log#ldebug (lazy ("collapse_ctx:\n\n- fixed_ids:\n" ^ show_ids_sets old_ids ^ "\n\n- ctx0:\n" ^ eval_ctx_to_string ctx0 ^ "\n\n")); - let abs_kind = V.Loop (loop_id, None, LoopSynthInput) in + let abs_kind : abs_kind = Loop (loop_id, None, LoopSynthInput) in let can_end = true in let destructure_shared_values = true in - let is_fresh_abs_id (id : V.AbstractionId.id) : bool = - not (V.AbstractionId.Set.mem id old_ids.aids) + let is_fresh_abs_id (id : AbstractionId.id) : bool = + not (AbstractionId.Set.mem id old_ids.aids) in - let is_fresh_did (id : C.DummyVarId.id) : bool = - not (C.DummyVarId.Set.mem id old_ids.dids) + let is_fresh_did (id : DummyVarId.id) : bool = + not (DummyVarId.Set.mem id old_ids.dids) in (* Convert the dummy values to abstractions (note that when we convert values to abstractions, the resulting abstraction should be destructured) *) @@ -163,18 +155,18 @@ let collapse_ctx (loop_id : V.LoopId.id) (List.map (fun ee -> match ee with - | C.EAbs _ | C.EFrame | C.EBinding (BVar _, _) -> [ ee ] - | C.EBinding (BDummy id, v) -> + | EAbs _ | EFrame | EBinding (BVar _, _) -> [ ee ] + | EBinding (BDummy id, v) -> if is_fresh_did id then let absl = convert_value_to_abstractions abs_kind can_end destructure_shared_values ctx0 v in - List.map (fun abs -> C.EAbs abs) absl + List.map (fun abs -> EAbs abs) absl else [ ee ]) ctx0.env) in - let ctx = { ctx0 with C.env } in + let ctx = { ctx0 with env } in log#ldebug (lazy ("collapse_ctx: after converting values to abstractions:\n" @@ -188,7 +180,7 @@ let collapse_ctx (loop_id : V.LoopId.id) )); (* Explore all the *new* abstractions, and compute various maps *) - let explore (abs : V.abs) = is_fresh_abs_id abs.abs_id in + let explore (abs : abs) = is_fresh_abs_id abs.abs_id in let ids_maps = compute_abs_borrows_loans_maps (merge_funs = None) explore env in @@ -211,8 +203,9 @@ let collapse_ctx (loop_id : V.LoopId.id) in (* Merge the abstractions together *) - let merged_abs : V.AbstractionId.id UF.elem V.AbstractionId.Map.t = - V.AbstractionId.Map.of_list (List.map (fun id -> (id, UF.make id)) abs_ids) + let merged_abs : AbstractionId.id UnionFind.elem AbstractionId.Map.t = + AbstractionId.Map.of_list + (List.map (fun id -> (id, UnionFind.make id)) abs_ids) in let ctx = ref ctx in @@ -226,26 +219,26 @@ let collapse_ctx (loop_id : V.LoopId.id) *) List.iter (fun abs_id0 -> - let bids = V.AbstractionId.Map.find abs_id0 abs_to_borrows in - let bids = V.BorrowId.Set.elements bids in + let bids = AbstractionId.Map.find abs_id0 abs_to_borrows in + let bids = BorrowId.Set.elements bids in List.iter (fun bid -> - match V.BorrowId.Map.find_opt bid loan_to_abs with + match BorrowId.Map.find_opt bid loan_to_abs with | None -> (* Nothing to do *) () | Some abs_ids1 -> - V.AbstractionId.Set.iter + AbstractionId.Set.iter (fun abs_id1 -> (* We need to merge - unless we have already merged *) (* First, find the representatives for the two abstractions (the representative is the abstraction into which we merged) *) let abs_ref0 = - UF.find (V.AbstractionId.Map.find abs_id0 merged_abs) + UnionFind.find (AbstractionId.Map.find abs_id0 merged_abs) in - let abs_id0 = UF.get abs_ref0 in + let abs_id0 = UnionFind.get abs_ref0 in let abs_ref1 = - UF.find (V.AbstractionId.Map.find abs_id1 merged_abs) + UnionFind.find (AbstractionId.Map.find abs_id1 merged_abs) in - let abs_id1 = UF.get abs_ref1 in + let abs_id1 = UnionFind.get abs_ref1 in (* If the two ids are the same, it means the abstractions were already merged *) if abs_id0 = abs_id1 then () else ( @@ -255,9 +248,9 @@ let collapse_ctx (loop_id : V.LoopId.id) log#ldebug (lazy ("collapse_ctx: merging abstraction " - ^ V.AbstractionId.to_string abs_id1 + ^ AbstractionId.to_string abs_id1 ^ " into " - ^ V.AbstractionId.to_string abs_id0 + ^ AbstractionId.to_string abs_id0 ^ ":\n\n" ^ eval_ctx_to_string !ctx)); (* Update the environment - pay attention to the order: we @@ -269,8 +262,8 @@ let collapse_ctx (loop_id : V.LoopId.id) ctx := nctx; (* Update the union find *) - let abs_ref_merged = UF.union abs_ref0 abs_ref1 in - UF.set abs_ref_merged abs_id)) + let abs_ref_merged = UnionFind.union abs_ref0 abs_ref1 in + UnionFind.set abs_ref_merged abs_id)) abs_ids1) bids) abs_ids; @@ -292,8 +285,8 @@ let collapse_ctx (loop_id : V.LoopId.id) (* Return the new context *) ctx -let mk_collapse_ctx_merge_duplicate_funs (loop_id : V.LoopId.id) - (ctx : C.eval_ctx) : merge_duplicates_funcs = +let mk_collapse_ctx_merge_duplicate_funs (loop_id : LoopId.id) (ctx : eval_ctx) + : merge_duplicates_funcs = (* Rem.: the merge functions raise exceptions (that we catch). *) let module S : MatchJoinState = struct let ctx = ctx @@ -314,8 +307,8 @@ let mk_collapse_ctx_merge_duplicate_funs (loop_id : V.LoopId.id) *) let merge_amut_borrows id ty0 child0 _ty1 child1 = (* Sanity checks *) - assert (is_aignored child0.V.value); - assert (is_aignored child1.V.value); + assert (is_aignored child0.value); + assert (is_aignored child1.value); (* We need to pick a type for the avalue. The types on the left and on the right may use different regions: it doesn't really matter (here, we pick @@ -324,8 +317,8 @@ let mk_collapse_ctx_merge_duplicate_funs (loop_id : V.LoopId.id) *) let ty = ty0 in let child = child0 in - let value = V.ABorrow (V.AMutBorrow (id, child)) in - { V.value; ty } + let value = ABorrow (AMutBorrow (id, child)) in + { value; ty } in let merge_ashared_borrows id ty0 ty1 = @@ -339,37 +332,37 @@ let mk_collapse_ctx_merge_duplicate_funs (loop_id : V.LoopId.id) (* Same remarks as for [merge_amut_borrows] *) let ty = ty0 in - let value = V.ABorrow (V.ASharedBorrow id) in - { V.value; ty } + let value = ABorrow (ASharedBorrow id) in + { value; ty } in let merge_amut_loans id ty0 child0 _ty1 child1 = (* Sanity checks *) - assert (is_aignored child0.V.value); - assert (is_aignored child1.V.value); + assert (is_aignored child0.value); + assert (is_aignored child1.value); (* Same remarks as for [merge_amut_borrows] *) let ty = ty0 in let child = child0 in - let value = V.ALoan (V.AMutLoan (id, child)) in - { V.value; ty } + let value = ALoan (AMutLoan (id, child)) in + { value; ty } in - let merge_ashared_loans ids ty0 (sv0 : V.typed_value) child0 _ty1 - (sv1 : V.typed_value) child1 = + let merge_ashared_loans ids ty0 (sv0 : typed_value) child0 _ty1 + (sv1 : typed_value) child1 = (* Sanity checks *) - assert (is_aignored child0.V.value); - assert (is_aignored child1.V.value); + assert (is_aignored child0.value); + assert (is_aignored child1.value); (* Same remarks as for [merge_amut_borrows]. This time we need to also merge the shared values. We rely on the join matcher [JM] to do so. *) - assert (not (value_has_loans_or_borrows ctx sv0.V.value)); - assert (not (value_has_loans_or_borrows ctx sv1.V.value)); + assert (not (value_has_loans_or_borrows ctx sv0.value)); + assert (not (value_has_loans_or_borrows ctx sv1.value)); let ty = ty0 in let child = child0 in let sv = M.match_typed_values ctx sv0 sv1 in - let value = V.ALoan (V.ASharedLoan (ids, sv, child)) in - { V.value; ty } + let value = ALoan (ASharedLoan (ids, sv, child)) in + { value; ty } in { merge_amut_borrows; @@ -378,9 +371,9 @@ let mk_collapse_ctx_merge_duplicate_funs (loop_id : V.LoopId.id) merge_ashared_loans; } -let merge_into_abstraction (loop_id : V.LoopId.id) (abs_kind : V.abs_kind) - (can_end : bool) (ctx : C.eval_ctx) (aid0 : V.AbstractionId.id) - (aid1 : V.AbstractionId.id) : C.eval_ctx * V.AbstractionId.id = +let merge_into_abstraction (loop_id : LoopId.id) (abs_kind : abs_kind) + (can_end : bool) (ctx : eval_ctx) (aid0 : AbstractionId.id) + (aid1 : AbstractionId.id) : eval_ctx * AbstractionId.id = let merge_funs = mk_collapse_ctx_merge_duplicate_funs loop_id ctx in merge_into_abstraction abs_kind can_end (Some merge_funs) ctx aid0 aid1 @@ -391,14 +384,14 @@ let merge_into_abstraction (loop_id : V.LoopId.id) (abs_kind : V.abs_kind) We do this because when we join environments, we may introduce duplicated loans and borrows. See the explanations for {!join_ctxs}. *) -let collapse_ctx_with_merge (loop_id : V.LoopId.id) (old_ids : ids_sets) - (ctx : C.eval_ctx) : C.eval_ctx = +let collapse_ctx_with_merge (loop_id : LoopId.id) (old_ids : ids_sets) + (ctx : eval_ctx) : eval_ctx = let merge_funs = mk_collapse_ctx_merge_duplicate_funs loop_id ctx in try collapse_ctx loop_id (Some merge_funs) old_ids ctx with ValueMatchFailure _ -> raise (Failure "Unexpected") -let join_ctxs (loop_id : V.LoopId.id) (fixed_ids : ids_sets) (ctx0 : C.eval_ctx) - (ctx1 : C.eval_ctx) : ctx_or_update = +let join_ctxs (loop_id : LoopId.id) (fixed_ids : ids_sets) (ctx0 : eval_ctx) + (ctx1 : eval_ctx) : ctx_or_update = (* Debug *) log#ldebug (lazy @@ -422,7 +415,7 @@ let join_ctxs (loop_id : V.LoopId.id) (fixed_ids : ids_sets) (ctx0 : C.eval_ctx) let nabs = ref [] in (* Explore the environments. *) - let join_suffixes (env0 : C.env) (env1 : C.env) : C.env = + let join_suffixes (env0 : env) (env1 : env) : env = (* Debug *) log#ldebug (lazy @@ -434,15 +427,15 @@ let join_ctxs (loop_id : V.LoopId.id) (fixed_ids : ids_sets) (ctx0 : C.eval_ctx) ^ "\n\n")); (* Sanity check: there are no values/abstractions which should be in the prefix *) - let check_valid (ee : C.env_elem) : unit = + let check_valid (ee : env_elem) : unit = match ee with - | C.EBinding (C.BVar _, _) -> + | EBinding (BVar _, _) -> (* Variables are necessarily in the prefix *) raise (Failure "Unreachable") - | EBinding (C.BDummy did, _) -> - assert (not (C.DummyVarId.Set.mem did fixed_ids.dids)) + | EBinding (BDummy did, _) -> + assert (not (DummyVarId.Set.mem did fixed_ids.dids)) | EAbs abs -> - assert (not (V.AbstractionId.Set.mem abs.abs_id fixed_ids.aids)) + assert (not (AbstractionId.Set.mem abs.abs_id fixed_ids.aids)) | EFrame -> (* This should have been eliminated *) raise (Failure "Unreachable") @@ -451,7 +444,7 @@ let join_ctxs (loop_id : V.LoopId.id) (fixed_ids : ids_sets) (ctx0 : C.eval_ctx) List.iter check_valid env1; (* Concatenate the suffixes and append the abstractions introduced while joining the prefixes *) - let absl = List.map (fun abs -> C.EAbs abs) (List.rev !nabs) in + let absl = List.map (fun abs -> EAbs abs) (List.rev !nabs) in List.concat [ env0; env1; absl ] in @@ -464,10 +457,10 @@ let join_ctxs (loop_id : V.LoopId.id) (fixed_ids : ids_sets) (ctx0 : C.eval_ctx) let module JM = MakeJoinMatcher (S) in let module M = MakeMatcher (JM) in (* Rem.: this function raises exceptions *) - let rec join_prefixes (env0 : C.env) (env1 : C.env) : C.env = + let rec join_prefixes (env0 : env) (env1 : env) : env = match (env0, env1) with - | ( (C.EBinding (C.BDummy b0, v0) as var0) :: env0', - (C.EBinding (C.BDummy b1, v1) as var1) :: env1' ) -> + | ( (EBinding (BDummy b0, v0) as var0) :: env0', + (EBinding (BDummy b1, v1) as var1) :: env1' ) -> (* Debug *) log#ldebug (lazy @@ -481,18 +474,18 @@ let join_ctxs (loop_id : V.LoopId.id) (fixed_ids : ids_sets) (ctx0 : C.eval_ctx) (* Two cases: the dummy value is an old value, in which case the bindings must be the same and we must join their values. Otherwise, it means we are not in the prefix anymore *) - if C.DummyVarId.Set.mem b0 fixed_ids.dids then ( + if DummyVarId.Set.mem b0 fixed_ids.dids then ( (* Still in the prefix: match the values *) assert (b0 = b1); let b = b0 in let v = M.match_typed_values ctx v0 v1 in - let var = C.EBinding (C.BDummy b, v) in + let var = EBinding (BDummy b, v) in (* Continue *) var :: join_prefixes env0' env1') else (* Not in the prefix anymore *) join_suffixes env0 env1 - | ( (C.EBinding (C.BVar b0, v0) as var0) :: env0', - (C.EBinding (C.BVar b1, v1) as var1) :: env1' ) -> + | ( (EBinding (BVar b0, v0) as var0) :: env0', + (EBinding (BVar b1, v1) as var1) :: env1' ) -> (* Debug *) log#ldebug (lazy @@ -509,10 +502,10 @@ let join_ctxs (loop_id : V.LoopId.id) (fixed_ids : ids_sets) (ctx0 : C.eval_ctx) (* Match the values *) let b = b0 in let v = M.match_typed_values ctx v0 v1 in - let var = C.EBinding (C.BVar b, v) in + let var = EBinding (BVar b, v) in (* Continue *) var :: join_prefixes env0' env1' - | (C.EAbs abs0 as abs) :: env0', C.EAbs abs1 :: env1' -> + | (EAbs abs0 as abs) :: env0', EAbs abs1 :: env1' -> (* Debug *) log#ldebug (lazy @@ -521,7 +514,7 @@ let join_ctxs (loop_id : V.LoopId.id) (fixed_ids : ids_sets) (ctx0 : C.eval_ctx) ^ "\n\n- abs1:\n" ^ abs_to_string ctx abs1 ^ "\n\n")); (* Same as for the dummy values: there are two cases *) - if V.AbstractionId.Set.mem abs0.abs_id fixed_ids.aids then ( + if AbstractionId.Set.mem abs0.abs_id fixed_ids.aids then ( (* Still in the prefix: the abstractions must be the same *) assert (abs0 = abs1); (* Continue *) @@ -537,21 +530,20 @@ let join_ctxs (loop_id : V.LoopId.id) (fixed_ids : ids_sets) (ctx0 : C.eval_ctx) (* Remove the frame delimiter (the first element of an environment is a frame delimiter) *) let env0, env1 = match (env0, env1) with - | C.EFrame :: env0, C.EFrame :: env1 -> (env0, env1) + | EFrame :: env0, EFrame :: env1 -> (env0, env1) | _ -> raise (Failure "Unreachable") in log#ldebug (lazy - ("- env0:\n" ^ C.show_env env0 ^ "\n\n- env1:\n" ^ C.show_env env1 - ^ "\n\n")); + ("- env0:\n" ^ show_env env0 ^ "\n\n- env1:\n" ^ show_env env1 ^ "\n\n")); - let env = List.rev (C.EFrame :: join_prefixes env0 env1) in + let env = List.rev (EFrame :: join_prefixes env0 env1) in (* Construct the joined context - of course, the type, fun, etc. contexts * should be the same in the two contexts *) let { - C.type_context; + type_context; fun_context; global_context; trait_decls_context; @@ -567,7 +559,7 @@ let join_ctxs (loop_id : V.LoopId.id) (fixed_ids : ids_sets) (ctx0 : C.eval_ctx) ctx0 in let { - C.type_context = _; + type_context = _; fun_context = _; global_context = _; trait_decls_context = _; @@ -582,10 +574,10 @@ let join_ctxs (loop_id : V.LoopId.id) (fixed_ids : ids_sets) (ctx0 : C.eval_ctx) } = ctx1 in - let ended_regions = T.RegionId.Set.union ended_regions0 ended_regions1 in + let ended_regions = RegionId.Set.union ended_regions0 ended_regions1 in Ok { - C.type_context; + type_context; fun_context; global_context; trait_decls_context; @@ -601,16 +593,16 @@ let join_ctxs (loop_id : V.LoopId.id) (fixed_ids : ids_sets) (ctx0 : C.eval_ctx) with ValueMatchFailure e -> Error e (** Destructure all the new abstractions *) -let destructure_new_abs (loop_id : V.LoopId.id) - (old_abs_ids : V.AbstractionId.Set.t) (ctx : C.eval_ctx) : C.eval_ctx = - let abs_kind = V.Loop (loop_id, None, V.LoopSynthInput) in +let destructure_new_abs (loop_id : LoopId.id) + (old_abs_ids : AbstractionId.Set.t) (ctx : eval_ctx) : eval_ctx = + let abs_kind : abs_kind = Loop (loop_id, None, LoopSynthInput) in let can_end = true in let destructure_shared_values = true in - let is_fresh_abs_id (id : V.AbstractionId.id) : bool = - not (V.AbstractionId.Set.mem id old_abs_ids) + let is_fresh_abs_id (id : AbstractionId.id) : bool = + not (AbstractionId.Set.mem id old_abs_ids) in let env = - C.env_map_abs + env_map_abs (fun abs -> if is_fresh_abs_id abs.abs_id then let abs = @@ -628,23 +620,22 @@ let destructure_new_abs (loop_id : V.LoopId.id) abstractions in contexts which are later joined: we have to make sure two contexts we join don't have non-fixed abstractions with the same ids. *) -let refresh_abs (old_abs : V.AbstractionId.Set.t) (ctx : C.eval_ctx) : - C.eval_ctx = +let refresh_abs (old_abs : AbstractionId.Set.t) (ctx : eval_ctx) : eval_ctx = let ids, _ = compute_context_ids ctx in - let abs_to_refresh = V.AbstractionId.Set.diff ids.aids old_abs in + let abs_to_refresh = AbstractionId.Set.diff ids.aids old_abs in let aids_subst = List.map - (fun id -> (id, C.fresh_abstraction_id ())) - (V.AbstractionId.Set.elements abs_to_refresh) + (fun id -> (id, fresh_abstraction_id ())) + (AbstractionId.Set.elements abs_to_refresh) in - let aids_subst = V.AbstractionId.Map.of_list aids_subst in + let aids_subst = AbstractionId.Map.of_list aids_subst in let subst id = - match V.AbstractionId.Map.find_opt id aids_subst with + match AbstractionId.Map.find_opt id aids_subst with | None -> id | Some id -> id in let env = - Subst.env_subst_ids + Substitute.env_subst_ids (fun x -> x) (fun x -> x) (fun x -> x) @@ -652,11 +643,11 @@ let refresh_abs (old_abs : V.AbstractionId.Set.t) (ctx : C.eval_ctx) : (fun x -> x) subst ctx.env in - { ctx with C.env } + { ctx with env } -let loop_join_origin_with_continue_ctxs (config : C.config) - (loop_id : V.LoopId.id) (fixed_ids : ids_sets) (old_ctx : C.eval_ctx) - (ctxl : C.eval_ctx list) : (C.eval_ctx * C.eval_ctx list) * C.eval_ctx = +let loop_join_origin_with_continue_ctxs (config : config) (loop_id : LoopId.id) + (fixed_ids : ids_sets) (old_ctx : eval_ctx) (ctxl : eval_ctx list) : + (eval_ctx * eval_ctx list) * eval_ctx = (* # Join with the new contexts, one by one For every context, we repeteadly attempt to join it with the current @@ -666,7 +657,7 @@ let loop_join_origin_with_continue_ctxs (config : C.config) in the one we are trying to add to the join. *) let joined_ctx = ref old_ctx in - let rec join_one_aux (ctx : C.eval_ctx) : C.eval_ctx = + let rec join_one_aux (ctx : eval_ctx) : eval_ctx = match join_ctxs loop_id fixed_ids !joined_ctx ctx with | Ok nctx -> joined_ctx := nctx; @@ -683,7 +674,7 @@ let loop_join_origin_with_continue_ctxs (config : C.config) in join_one_aux ctx in - let join_one (ctx : C.eval_ctx) : C.eval_ctx = + let join_one (ctx : eval_ctx) : eval_ctx = log#ldebug (lazy ("loop_join_origin_with_continue_ctxs:join_one: initial ctx:\n" diff --git a/compiler/InterpreterLoopsJoinCtxs.mli b/compiler/InterpreterLoopsJoinCtxs.mli index ae655fb8..bb9f14ed 100644 --- a/compiler/InterpreterLoopsJoinCtxs.mli +++ b/compiler/InterpreterLoopsJoinCtxs.mli @@ -1,13 +1,5 @@ -module T = Types -module PV = PrimitiveValues -module V = Values -module E = Expressions -module C = Contexts -module Subst = Substitute -module A = LlbcAst -module L = Logging -module Inv = Invariants -module S = SynthesizeSymbolic +open Values +open Contexts open InterpreterUtils open InterpreterLoopsCore @@ -24,13 +16,13 @@ open InterpreterLoopsCore - [aid1] *) val merge_into_abstraction : - V.loop_id -> - V.abs_kind -> + loop_id -> + abs_kind -> bool -> - C.eval_ctx -> - V.abstraction_id -> - V.abstraction_id -> - C.eval_ctx * V.abstraction_id + eval_ctx -> + abstraction_id -> + abstraction_id -> + eval_ctx * abstraction_id (** Join two contexts. @@ -92,8 +84,7 @@ val merge_into_abstraction : - [ctx0] - [ctx1] *) -val join_ctxs : - V.loop_id -> ids_sets -> C.eval_ctx -> C.eval_ctx -> ctx_or_update +val join_ctxs : loop_id -> ids_sets -> eval_ctx -> eval_ctx -> ctx_or_update (** Join the context at the entry of the loop with the contexts upon reentry (upon reaching the [Continue] statement - the goal is to compute a fixed @@ -112,9 +103,9 @@ val join_ctxs : - [ctxl] *) val loop_join_origin_with_continue_ctxs : - C.config -> - V.loop_id -> + config -> + loop_id -> ids_sets -> - C.eval_ctx -> - C.eval_ctx list -> - (C.eval_ctx * C.eval_ctx list) * C.eval_ctx + eval_ctx -> + eval_ctx list -> + (eval_ctx * eval_ctx list) * eval_ctx diff --git a/compiler/InterpreterLoopsMatchCtxs.ml b/compiler/InterpreterLoopsMatchCtxs.ml index 7741abbc..74f9ba2c 100644 --- a/compiler/InterpreterLoopsMatchCtxs.ml +++ b/compiler/InterpreterLoopsMatchCtxs.ml @@ -4,35 +4,29 @@ to check if two contexts are equivalent (modulo conversion). *) -module T = Types -module PV = PrimitiveValues -module V = Values -module E = Expressions -module C = Contexts -module Subst = Substitute -module A = LlbcAst -module L = Logging +open Types +open Values +open Contexts open TypesUtils open ValuesUtils -module Inv = Invariants -module S = SynthesizeSymbolic open Cps open InterpreterUtils open InterpreterBorrows open InterpreterLoopsCore +module S = SynthesizeSymbolic (** The local logger *) -let log = L.loops_match_ctxs_log +let log = Logging.loops_match_ctxs_log let compute_abs_borrows_loans_maps (no_duplicates : bool) - (explore : V.abs -> bool) (env : C.env) : abs_borrows_loans_maps = + (explore : abs -> bool) (env : env) : abs_borrows_loans_maps = let abs_ids = ref [] in - let abs_to_borrows = ref V.AbstractionId.Map.empty in - let abs_to_loans = ref V.AbstractionId.Map.empty in - let abs_to_borrows_loans = ref V.AbstractionId.Map.empty in - let borrow_to_abs = ref V.BorrowId.Map.empty in - let loan_to_abs = ref V.BorrowId.Map.empty in - let borrow_loan_to_abs = ref V.BorrowId.Map.empty in + let abs_to_borrows = ref AbstractionId.Map.empty in + let abs_to_loans = ref AbstractionId.Map.empty in + let abs_to_borrows_loans = ref AbstractionId.Map.empty in + let borrow_to_abs = ref BorrowId.Map.empty in + let loan_to_abs = ref BorrowId.Map.empty in + let borrow_loan_to_abs = ref BorrowId.Map.empty in let module R (Id0 : Identifiers.Id) (Id1 : Identifiers.Id) = struct (* @@ -65,8 +59,8 @@ let compute_abs_borrows_loans_maps (no_duplicates : bool) Some (Id1.Set.add id1 ids)) !map end in - let module RAbsBorrow = R (V.AbstractionId) (V.BorrowId) in - let module RBorrowAbs = R (V.BorrowId) (V.AbstractionId) in + let module RAbsBorrow = R (AbstractionId) (BorrowId) in + let module RBorrowAbs = R (BorrowId) (AbstractionId) in let register_borrow_id abs_id bid = RAbsBorrow.register_mapping false no_duplicates abs_to_borrows abs_id bid; RAbsBorrow.register_mapping false false abs_to_borrows_loans abs_id bid; @@ -85,7 +79,7 @@ let compute_abs_borrows_loans_maps (no_duplicates : bool) let explore_abs = object (self : 'self) - inherit [_] V.iter_typed_avalue as super + inherit [_] iter_typed_avalue as super (** Make sure we don't register the ignored ids *) method! visit_aloan_content abs_id lc = @@ -119,14 +113,14 @@ let compute_abs_borrows_loans_maps (no_duplicates : bool) end in - C.env_iter_abs + env_iter_abs (fun abs -> let abs_id = abs.abs_id in if explore abs then ( abs_to_borrows := - V.AbstractionId.Map.add abs_id V.BorrowId.Set.empty !abs_to_borrows; + AbstractionId.Map.add abs_id BorrowId.Set.empty !abs_to_borrows; abs_to_loans := - V.AbstractionId.Map.add abs_id V.BorrowId.Set.empty !abs_to_loans; + AbstractionId.Map.add abs_id BorrowId.Set.empty !abs_to_loans; abs_ids := abs.abs_id :: !abs_ids; List.iter (explore_abs#visit_typed_avalue abs.abs_id) abs.avalues) else ()) @@ -148,9 +142,8 @@ let compute_abs_borrows_loans_maps (no_duplicates : bool) TODO: probably don't need to take [match_regions] as input anymore. *) -let rec match_types (match_distinct_types : T.ty -> T.ty -> T.ty) - (match_regions : T.region -> T.region -> T.region) (ty0 : T.ty) (ty1 : T.ty) - : T.ty = +let rec match_types (match_distinct_types : ty -> ty -> ty) + (match_regions : region -> region -> region) (ty0 : ty) (ty1 : ty) : ty = let match_rec = match_types match_distinct_types match_regions in match (ty0, ty1) with | TAdt (id0, generics0), TAdt (id1, generics1) -> @@ -170,7 +163,7 @@ let rec match_types (match_distinct_types : T.ty -> T.ty -> T.ty) (fun (ty0, ty1) -> match_rec ty0 ty1) (List.combine generics0.types generics1.types) in - let generics = { T.regions; types; const_generics; trait_refs } in + let generics = { regions; types; const_generics; trait_refs } in TAdt (id, generics) | TVar vid0, TVar vid1 -> assert (vid0 = vid1); @@ -189,27 +182,27 @@ let rec match_types (match_distinct_types : T.ty -> T.ty -> T.ty) | _ -> match_distinct_types ty0 ty1 module MakeMatcher (M : PrimMatcher) : Matcher = struct - let rec match_typed_values (ctx : C.eval_ctx) (v0 : V.typed_value) - (v1 : V.typed_value) : V.typed_value = + let rec match_typed_values (ctx : eval_ctx) (v0 : typed_value) + (v1 : typed_value) : typed_value = let match_rec = match_typed_values ctx in - let ty = M.match_etys v0.V.ty v1.V.ty in - match (v0.V.value, v1.V.value) with - | V.VLiteral lv0, V.VLiteral lv1 -> + let ty = M.match_etys v0.ty v1.ty in + match (v0.value, v1.value) with + | VLiteral lv0, VLiteral lv1 -> if lv0 = lv1 then v1 else M.match_distinct_literals ty lv0 lv1 - | V.VAdt av0, V.VAdt av1 -> + | VAdt av0, VAdt av1 -> if av0.variant_id = av1.variant_id then let fields = List.combine av0.field_values av1.field_values in let field_values = List.map (fun (f0, f1) -> match_rec f0 f1) fields in - let value : V.value = - V.VAdt { variant_id = av0.variant_id; field_values } + let value : value = + VAdt { variant_id = av0.variant_id; field_values } in - { V.value; ty = v1.V.ty } + { value; ty = v1.ty } else ( (* For now, we don't merge ADTs which contain borrows *) - assert (not (value_has_borrows ctx v0.V.value)); - assert (not (value_has_borrows ctx v1.V.value)); + assert (not (value_has_borrows ctx v0.value)); + assert (not (value_has_borrows ctx v1.value)); (* Merge *) M.match_distinct_adts ty av0 av1) | VBottom, VBottom -> v0 @@ -218,10 +211,10 @@ module MakeMatcher (M : PrimMatcher) : Matcher = struct match (bc0, bc1) with | VSharedBorrow bid0, VSharedBorrow bid1 -> let bid = M.match_shared_borrows match_rec ty bid0 bid1 in - V.VSharedBorrow bid + VSharedBorrow bid | VMutBorrow (bid0, bv0), VMutBorrow (bid1, bv1) -> let bv = match_rec bv0 bv1 in - assert (not (value_has_borrows ctx bv.V.value)); + assert (not (value_has_borrows ctx bv.value)); let bid, bv = M.match_mut_borrows ty bid0 bv0 bid1 bv1 bv in VMutBorrow (bid, bv) | VReservedMutBorrow _, _ @@ -234,7 +227,7 @@ module MakeMatcher (M : PrimMatcher) : Matcher = struct just before function calls which activate them *) raise (Failure "Unexpected") in - { V.value = VBorrow bc; ty } + { value = VBorrow bc; ty } | VLoan lc0, VLoan lc1 -> (* TODO: maybe we should enforce that the ids are always exactly the same - without matching *) @@ -242,24 +235,24 @@ module MakeMatcher (M : PrimMatcher) : Matcher = struct match (lc0, lc1) with | VSharedLoan (ids0, sv0), VSharedLoan (ids1, sv1) -> let sv = match_rec sv0 sv1 in - assert (not (value_has_borrows ctx sv.V.value)); + assert (not (value_has_borrows ctx sv.value)); let ids, sv = M.match_shared_loans ty ids0 ids1 sv in - V.VSharedLoan (ids, sv) + VSharedLoan (ids, sv) | VMutLoan id0, VMutLoan id1 -> let id = M.match_mut_loans ty id0 id1 in VMutLoan id | VSharedLoan _, VMutLoan _ | VMutLoan _, VSharedLoan _ -> raise (Failure "Unreachable") in - { V.value = VLoan lc; ty = v1.V.ty } + { value = VLoan lc; ty = v1.ty } | VSymbolic sv0, VSymbolic sv1 -> (* For now, we force all the symbolic values containing borrows to be eagerly expanded, and we don't support nested borrows *) - assert (not (value_has_borrows ctx v0.V.value)); - assert (not (value_has_borrows ctx v1.V.value)); + assert (not (value_has_borrows ctx v0.value)); + assert (not (value_has_borrows ctx v1.value)); (* Match *) let sv = M.match_symbolic_values sv0 sv1 in - { v1 with V.value = VSymbolic sv } + { v1 with value = VSymbolic sv } | VLoan lc, _ -> ( match lc with | VSharedLoan (ids, _) -> raise (ValueMatchFailure (LoansInLeft ids)) @@ -281,8 +274,8 @@ module MakeMatcher (M : PrimMatcher) : Matcher = struct ^ typed_value_to_string ctx v1)); raise (Failure "Unexpected match case") - and match_typed_avalues (ctx : C.eval_ctx) (v0 : V.typed_avalue) - (v1 : V.typed_avalue) : V.typed_avalue = + and match_typed_avalues (ctx : eval_ctx) (v0 : typed_avalue) + (v1 : typed_avalue) : typed_avalue = log#ldebug (lazy ("match_typed_avalues:\n- value0: " @@ -292,20 +285,20 @@ module MakeMatcher (M : PrimMatcher) : Matcher = struct let match_rec = match_typed_values ctx in let match_arec = match_typed_avalues ctx in - let ty = M.match_rtys v0.V.ty v1.V.ty in - match (v0.V.value, v1.V.value) with - | V.AAdt av0, V.AAdt av1 -> + let ty = M.match_rtys v0.ty v1.ty in + match (v0.value, v1.value) with + | AAdt av0, AAdt av1 -> if av0.variant_id = av1.variant_id then let fields = List.combine av0.field_values av1.field_values in let field_values = List.map (fun (f0, f1) -> match_arec f0 f1) fields in - let value : V.avalue = - V.AAdt { variant_id = av0.variant_id; field_values } + let value : avalue = + AAdt { variant_id = av0.variant_id; field_values } in - { V.value; ty } + { value; ty } else (* Merge *) - M.match_distinct_aadts v0.V.ty av0 v1.V.ty av1 ty + M.match_distinct_aadts v0.ty av0 v1.ty av1 ty | ABottom, ABottom -> mk_abottom ty | AIgnored, AIgnored -> mk_aignored ty | ABorrow bc0, ABorrow bc1 -> ( @@ -313,7 +306,7 @@ module MakeMatcher (M : PrimMatcher) : Matcher = struct match (bc0, bc1) with | ASharedBorrow bid0, ASharedBorrow bid1 -> log#ldebug (lazy "match_typed_avalues: shared borrows"); - M.match_ashared_borrows v0.V.ty bid0 v1.V.ty bid1 ty + M.match_ashared_borrows v0.ty bid0 v1.ty bid1 ty | AMutBorrow (bid0, av0), AMutBorrow (bid1, av1) -> log#ldebug (lazy "match_typed_avalues: mut borrows"); log#ldebug @@ -322,7 +315,7 @@ module MakeMatcher (M : PrimMatcher) : Matcher = struct let av = match_arec av0 av1 in log#ldebug (lazy "match_typed_avalues: mut borrows: matched children values"); - M.match_amut_borrows v0.V.ty bid0 av0 v1.V.ty bid1 av1 ty av + M.match_amut_borrows v0.ty bid0 av0 v1.ty bid1 av1 ty av | AIgnoredMutBorrow _, AIgnoredMutBorrow _ -> (* The abstractions are destructured: we shouldn't get there *) raise (Failure "Unexpected") @@ -355,9 +348,8 @@ module MakeMatcher (M : PrimMatcher) : Matcher = struct log#ldebug (lazy "match_typed_avalues: shared loans"); let sv = match_rec sv0 sv1 in let av = match_arec av0 av1 in - assert (not (value_has_borrows ctx sv.V.value)); - M.match_ashared_loans v0.V.ty ids0 sv0 av0 v1.V.ty ids1 sv1 av1 ty - sv av + assert (not (value_has_borrows ctx sv.value)); + M.match_ashared_loans v0.ty ids0 sv0 av0 v1.ty ids1 sv1 av1 ty sv av | AMutLoan (id0, av0), AMutLoan (id1, av1) -> log#ldebug (lazy "match_typed_avalues: mut loans"); log#ldebug @@ -365,7 +357,7 @@ module MakeMatcher (M : PrimMatcher) : Matcher = struct let av = match_arec av0 av1 in log#ldebug (lazy "match_typed_avalues: mut loans: matched children values"); - M.match_amut_loans v0.V.ty id0 av0 v1.V.ty id1 av1 ty av + M.match_amut_loans v0.ty id0 av0 v1.ty id1 av1 ty av | AIgnoredMutLoan _, AIgnoredMutLoan _ | AIgnoredSharedLoan _, AIgnoredSharedLoan _ -> (* Those should have been filtered when destructuring the abstractions - @@ -381,9 +373,9 @@ end module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct (** Small utility *) - let push_abs (abs : V.abs) : unit = S.nabs := abs :: !S.nabs + let push_abs (abs : abs) : unit = S.nabs := abs :: !S.nabs - let push_absl (absl : V.abs list) : unit = List.iter push_abs absl + let push_absl (absl : abs list) : unit = List.iter push_abs absl let match_etys ty0 ty1 = assert (ty0 = ty1); @@ -395,24 +387,24 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct assert (ty0 = ty1); ty0 - let match_distinct_literals (ty : T.ety) (_ : V.literal) (_ : V.literal) : - V.typed_value = - mk_fresh_symbolic_typed_value_from_no_regions_ty V.LoopJoin ty + let match_distinct_literals (ty : ety) (_ : literal) (_ : literal) : + typed_value = + mk_fresh_symbolic_typed_value_from_no_regions_ty LoopJoin ty - let match_distinct_adts (ty : T.ety) (adt0 : V.adt_value) (adt1 : V.adt_value) - : V.typed_value = + let match_distinct_adts (ty : ety) (adt0 : adt_value) (adt1 : adt_value) : + typed_value = (* Check that the ADTs don't contain borrows - this is redundant with checks performed by the caller, but we prefer to be safe with regards to future updates *) - let check_no_borrows (v : V.typed_value) = - assert (not (value_has_borrows S.ctx v.V.value)) + let check_no_borrows (v : typed_value) = + assert (not (value_has_borrows S.ctx v.value)) in List.iter check_no_borrows adt0.field_values; List.iter check_no_borrows adt1.field_values; (* Check if there are loans: we request to end them *) - let check_loans (left : bool) (fields : V.typed_value list) : unit = + let check_loans (left : bool) (fields : typed_value list) : unit = match InterpreterBorrowsCore.get_first_loan_in_values fields with | Some (VSharedLoan (ids, _)) -> if left then raise (ValueMatchFailure (LoansInLeft ids)) @@ -426,10 +418,10 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct check_loans false adt1.field_values; (* No borrows, no loans: we can introduce a symbolic value *) - mk_fresh_symbolic_typed_value_from_no_regions_ty V.LoopJoin ty + mk_fresh_symbolic_typed_value_from_no_regions_ty LoopJoin ty - let match_shared_borrows _ (ty : T.ety) (bid0 : V.borrow_id) - (bid1 : V.borrow_id) : V.borrow_id = + let match_shared_borrows _ (ty : ety) (bid0 : borrow_id) (bid1 : borrow_id) : + borrow_id = if bid0 = bid1 then bid0 else (* We replace bid0 and bid1 with a fresh borrow id, and introduce @@ -438,42 +430,42 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct { SB bid0, SB bid1, SL {bid2} } ]} *) - let rid = C.fresh_region_id () in - let bid2 = C.fresh_borrow_id () in + let rid = fresh_region_id () in + let bid2 = fresh_borrow_id () in (* Generate a fresh symbolic value for the shared value *) let _, bv_ty, kind = ty_as_ref ty in let sv = - mk_fresh_symbolic_typed_value_from_no_regions_ty V.LoopJoin bv_ty + mk_fresh_symbolic_typed_value_from_no_regions_ty LoopJoin bv_ty in - let borrow_ty = mk_ref_ty (T.RVar rid) bv_ty kind in + let borrow_ty = mk_ref_ty (RVar rid) bv_ty kind in (* Generate the avalues for the abstraction *) - let mk_aborrow (bid : V.borrow_id) : V.typed_avalue = - let value = V.ABorrow (V.ASharedBorrow bid) in - { V.value; ty = borrow_ty } + let mk_aborrow (bid : borrow_id) : typed_avalue = + let value = ABorrow (ASharedBorrow bid) in + { value; ty = borrow_ty } in let borrows = [ mk_aborrow bid0; mk_aborrow bid1 ] in let loan = - V.ASharedLoan (V.BorrowId.Set.singleton bid2, sv, mk_aignored bv_ty) + ASharedLoan (BorrowId.Set.singleton bid2, sv, mk_aignored bv_ty) in (* Note that an aloan has a borrow type *) - let loan = { V.value = V.ALoan loan; ty = borrow_ty } in + let loan : typed_avalue = { value = ALoan loan; ty = borrow_ty } in let avalues = List.append borrows [ loan ] in (* Generate the abstraction *) let abs = { - V.abs_id = C.fresh_abstraction_id (); - kind = V.Loop (S.loop_id, None, LoopSynthInput); + abs_id = fresh_abstraction_id (); + kind = Loop (S.loop_id, None, LoopSynthInput); can_end = true; - parents = V.AbstractionId.Set.empty; + parents = AbstractionId.Set.empty; original_parents = []; - regions = T.RegionId.Set.singleton rid; - ancestors_regions = T.RegionId.Set.empty; + regions = RegionId.Set.singleton rid; + ancestors_regions = RegionId.Set.empty; avalues; } in @@ -482,9 +474,9 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct (* Return the new borrow *) bid2 - let match_mut_borrows (ty : T.ety) (bid0 : V.borrow_id) (bv0 : V.typed_value) - (bid1 : V.borrow_id) (bv1 : V.typed_value) (bv : V.typed_value) : - V.borrow_id * V.typed_value = + let match_mut_borrows (ty : ety) (bid0 : borrow_id) (bv0 : typed_value) + (bid1 : borrow_id) (bv1 : typed_value) (bv : typed_value) : + borrow_id * typed_value = if bid0 = bid1 then ( (* If the merged value is not the same as the original value, we introduce an abstraction: @@ -533,29 +525,29 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct do so, we won't introduce reborrows like above: the forward loop function will update [v], while the backward loop function will return nothing. *) - assert (not (value_has_borrows S.ctx bv.V.value)); + assert (not (value_has_borrows S.ctx bv.value)); if bv0 = bv1 then ( assert (bv0 = bv); (bid0, bv)) else - let rid = C.fresh_region_id () in - let nbid = C.fresh_borrow_id () in + let rid = fresh_region_id () in + let nbid = fresh_borrow_id () in - let kind = T.Mut in - let bv_ty = bv.V.ty in + let kind = RMut in + let bv_ty = bv.ty in assert (ty_no_regions bv_ty); - let borrow_ty = mk_ref_ty (T.RVar rid) bv_ty kind in + let borrow_ty = mk_ref_ty (RVar rid) bv_ty kind in let borrow_av = let ty = borrow_ty in - let value = V.ABorrow (V.AMutBorrow (bid0, mk_aignored bv_ty)) in + let value = ABorrow (AMutBorrow (bid0, mk_aignored bv_ty)) in mk_typed_avalue ty value in let loan_av = let ty = borrow_ty in - let value = V.ALoan (V.AMutLoan (nbid, mk_aignored bv_ty)) in + let value = ALoan (AMutLoan (nbid, mk_aignored bv_ty)) in mk_typed_avalue ty value in @@ -564,13 +556,13 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct (* Generate the abstraction *) let abs = { - V.abs_id = C.fresh_abstraction_id (); - kind = V.Loop (S.loop_id, None, LoopSynthInput); + abs_id = fresh_abstraction_id (); + kind = Loop (S.loop_id, None, LoopSynthInput); can_end = true; - parents = V.AbstractionId.Set.empty; + parents = AbstractionId.Set.empty; original_parents = []; - regions = T.RegionId.Set.singleton rid; - ancestors_regions = T.RegionId.Set.empty; + regions = RegionId.Set.singleton rid; + ancestors_regions = RegionId.Set.empty; avalues; } in @@ -585,42 +577,42 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct { MB bid0, MB bid1, ML bid2 } ]} *) - let rid = C.fresh_region_id () in - let bid2 = C.fresh_borrow_id () in + let rid = fresh_region_id () in + let bid2 = fresh_borrow_id () in (* Generate a fresh symbolic value for the borrowed value *) let _, bv_ty, kind = ty_as_ref ty in let sv = - mk_fresh_symbolic_typed_value_from_no_regions_ty V.LoopJoin bv_ty + mk_fresh_symbolic_typed_value_from_no_regions_ty LoopJoin bv_ty in - let borrow_ty = mk_ref_ty (T.RVar rid) bv_ty kind in + let borrow_ty = mk_ref_ty (RVar rid) bv_ty kind in (* Generate the avalues for the abstraction *) - let mk_aborrow (bid : V.borrow_id) (bv : V.typed_value) : V.typed_avalue = - let bv_ty = bv.V.ty in + let mk_aborrow (bid : borrow_id) (bv : typed_value) : typed_avalue = + let bv_ty = bv.ty in assert (ty_no_regions bv_ty); - let value = V.ABorrow (V.AMutBorrow (bid, mk_aignored bv_ty)) in - { V.value; ty = borrow_ty } + let value = ABorrow (AMutBorrow (bid, mk_aignored bv_ty)) in + { value; ty = borrow_ty } in let borrows = [ mk_aborrow bid0 bv0; mk_aborrow bid1 bv1 ] in - let loan = V.AMutLoan (bid2, mk_aignored bv_ty) in + let loan = AMutLoan (bid2, mk_aignored bv_ty) in (* Note that an aloan has a borrow type *) - let loan = { V.value = V.ALoan loan; ty = borrow_ty } in + let loan : typed_avalue = { value = ALoan loan; ty = borrow_ty } in let avalues = List.append borrows [ loan ] in (* Generate the abstraction *) let abs = { - V.abs_id = C.fresh_abstraction_id (); - kind = V.Loop (S.loop_id, None, LoopSynthInput); + abs_id = fresh_abstraction_id (); + kind = Loop (S.loop_id, None, LoopSynthInput); can_end = true; - parents = V.AbstractionId.Set.empty; + parents = AbstractionId.Set.empty; original_parents = []; - regions = T.RegionId.Set.singleton rid; - ancestors_regions = T.RegionId.Set.empty; + regions = RegionId.Set.singleton rid; + ancestors_regions = RegionId.Set.empty; avalues; } in @@ -629,20 +621,19 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct (* Return the new borrow *) (bid2, sv) - let match_shared_loans (_ : T.ety) (ids0 : V.loan_id_set) - (ids1 : V.loan_id_set) (sv : V.typed_value) : - V.loan_id_set * V.typed_value = + let match_shared_loans (_ : ety) (ids0 : loan_id_set) (ids1 : loan_id_set) + (sv : typed_value) : loan_id_set * typed_value = (* Check if the ids are the same - Rem.: we forbid the sets of loans to be different. However, if we dive inside data-structures (by using a shared borrow) the shared values might themselves contain shared loans, which need to be matched. For this reason, we destructure the shared values (see {!destructure_abs}). *) - let extra_ids_left = V.BorrowId.Set.diff ids0 ids1 in - let extra_ids_right = V.BorrowId.Set.diff ids1 ids0 in - if not (V.BorrowId.Set.is_empty extra_ids_left) then + let extra_ids_left = BorrowId.Set.diff ids0 ids1 in + let extra_ids_right = BorrowId.Set.diff ids1 ids0 in + if not (BorrowId.Set.is_empty extra_ids_left) then raise (ValueMatchFailure (LoansInLeft extra_ids_left)); - if not (V.BorrowId.Set.is_empty extra_ids_right) then + if not (BorrowId.Set.is_empty extra_ids_right) then raise (ValueMatchFailure (LoansInRight extra_ids_right)); (* This should always be true if we get here *) @@ -652,16 +643,15 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct (* Return *) (ids, sv) - let match_mut_loans (_ : T.ety) (id0 : V.loan_id) (id1 : V.loan_id) : - V.loan_id = + let match_mut_loans (_ : ety) (id0 : loan_id) (id1 : loan_id) : loan_id = if id0 = id1 then id0 else (* We forbid this case for now: if we get there, we force to end both borrows *) raise (ValueMatchFailure (LoanInLeft id0)) - let match_symbolic_values (sv0 : V.symbolic_value) (sv1 : V.symbolic_value) : - V.symbolic_value = + let match_symbolic_values (sv0 : symbolic_value) (sv1 : symbolic_value) : + symbolic_value = let id0 = sv0.sv_id in let id1 = sv1.sv_id in if id0 = id1 then ( @@ -674,17 +664,17 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct borrows *) assert (not (ty_has_borrows S.ctx.type_context.type_infos sv0.sv_ty)); (* We simply introduce a fresh symbolic value *) - mk_fresh_symbolic_value V.LoopJoin sv0.sv_ty) + mk_fresh_symbolic_value LoopJoin sv0.sv_ty) - let match_symbolic_with_other (left : bool) (sv : V.symbolic_value) - (v : V.typed_value) : V.typed_value = + let match_symbolic_with_other (left : bool) (sv : symbolic_value) + (v : typed_value) : typed_value = (* Check that: - there are no borrows in the symbolic value - there are no borrows in the "regular" value If there are loans in the regular value, raise an exception. *) assert (not (ty_has_borrows S.ctx.type_context.type_infos sv.sv_ty)); - assert (not (value_has_borrows S.ctx v.V.value)); + assert (not (value_has_borrows S.ctx v.value)); let value_is_left = not left in (match InterpreterBorrowsCore.get_first_loan_in_value v with | None -> () @@ -695,10 +685,9 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct if value_is_left then raise (ValueMatchFailure (LoanInLeft id)) else raise (ValueMatchFailure (LoanInRight id))); (* Return a fresh symbolic value *) - mk_fresh_symbolic_typed_value V.LoopJoin sv.sv_ty + mk_fresh_symbolic_typed_value LoopJoin sv.sv_ty - let match_bottom_with_other (left : bool) (v : V.typed_value) : V.typed_value - = + let match_bottom_with_other (left : bool) (v : typed_value) : typed_value = (* If there are outer loans in the non-bottom value, raise an exception. Otherwise, convert it to an abstraction and return [Bottom]. *) @@ -719,7 +708,7 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct else raise (ValueMatchFailure (LoanInRight id))) | None -> (* Convert the value to an abstraction *) - let abs_kind = V.Loop (S.loop_id, None, LoopSynthInput) in + let abs_kind : abs_kind = Loop (S.loop_id, None, LoopSynthInput) in let can_end = true in let destructure_shared_values = true in let absl = @@ -728,7 +717,7 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct in push_absl absl; (* Return [Bottom] *) - mk_bottom v.V.ty + mk_bottom v.ty (* As explained in comments: we don't use the join matcher to join avalues, only concrete values *) @@ -785,12 +774,12 @@ struct (match_el msg m (Id.Set.elements ks0) (Id.Set.elements ks1)) end - module GetSetRid = MkGetSetM (T.RegionId) + module GetSetRid = MkGetSetM (RegionId) let match_rid = GetSetRid.match_e "match_rid: " S.rid_map let match_rids = GetSetRid.match_es "match_rids: " S.rid_map - module GetSetBid = MkGetSetM (V.BorrowId) + module GetSetBid = MkGetSetM (BorrowId) let match_blid msg = GetSetBid.match_e msg S.blid_map let match_blidl msg = GetSetBid.match_el msg S.blid_map @@ -820,8 +809,8 @@ struct if S.check_equiv then match_blids "match_loan_ids: " else GetSetBid.match_es "match_loan_ids: " S.loan_id_map - module GetSetSid = MkGetSetM (V.SymbolicValueId) - module GetSetAid = MkGetSetM (V.AbstractionId) + module GetSetSid = MkGetSetM (SymbolicValueId) + module GetSetAid = MkGetSetM (AbstractionId) let match_aid = GetSetAid.match_e "match_aid: " S.aid_map let match_aidl = GetSetAid.match_el "match_aidl: " S.aid_map @@ -835,7 +824,7 @@ struct let match_distinct_types _ _ = raise (Distinct "match_rtys") in let match_regions r0 r1 = match (r0, r1) with - | T.RStatic, T.RStatic -> r1 + | RStatic, RStatic -> r1 | RVar rid0, RVar rid1 -> let rid = match_rid rid0 rid1 in RVar rid @@ -843,21 +832,21 @@ struct in match_types match_distinct_types match_regions ty0 ty1 - let match_distinct_literals (ty : T.ety) (_ : V.literal) (_ : V.literal) : - V.typed_value = - mk_fresh_symbolic_typed_value_from_no_regions_ty V.LoopJoin ty + let match_distinct_literals (ty : ety) (_ : literal) (_ : literal) : + typed_value = + mk_fresh_symbolic_typed_value_from_no_regions_ty LoopJoin ty - let match_distinct_adts (_ty : T.ety) (_adt0 : V.adt_value) - (_adt1 : V.adt_value) : V.typed_value = + let match_distinct_adts (_ty : ety) (_adt0 : adt_value) (_adt1 : adt_value) : + typed_value = raise (Distinct "match_distinct_adts") let match_shared_borrows - (match_typed_values : V.typed_value -> V.typed_value -> V.typed_value) - (_ty : T.ety) (bid0 : V.borrow_id) (bid1 : V.borrow_id) : V.borrow_id = + (match_typed_values : typed_value -> typed_value -> typed_value) + (_ty : ety) (bid0 : borrow_id) (bid1 : borrow_id) : borrow_id = log#ldebug (lazy ("MakeCheckEquivMatcher: match_shared_borrows: " ^ "bid0: " - ^ V.BorrowId.to_string bid0 ^ ", bid1: " ^ V.BorrowId.to_string bid1)); + ^ BorrowId.to_string bid0 ^ ", bid1: " ^ BorrowId.to_string bid1)); let bid = match_borrow_id bid0 bid1 in (* If we don't check for equivalence (i.e., we apply a fixed-point), @@ -881,33 +870,31 @@ struct in bid - let match_mut_borrows (_ty : T.ety) (bid0 : V.borrow_id) - (_bv0 : V.typed_value) (bid1 : V.borrow_id) (_bv1 : V.typed_value) - (bv : V.typed_value) : V.borrow_id * V.typed_value = + let match_mut_borrows (_ty : ety) (bid0 : borrow_id) (_bv0 : typed_value) + (bid1 : borrow_id) (_bv1 : typed_value) (bv : typed_value) : + borrow_id * typed_value = let bid = match_borrow_id bid0 bid1 in (bid, bv) - let match_shared_loans (_ : T.ety) (ids0 : V.loan_id_set) - (ids1 : V.loan_id_set) (sv : V.typed_value) : - V.loan_id_set * V.typed_value = + let match_shared_loans (_ : ety) (ids0 : loan_id_set) (ids1 : loan_id_set) + (sv : typed_value) : loan_id_set * typed_value = let ids = match_loan_ids ids0 ids1 in (ids, sv) - let match_mut_loans (_ : T.ety) (bid0 : V.loan_id) (bid1 : V.loan_id) : - V.loan_id = + let match_mut_loans (_ : ety) (bid0 : loan_id) (bid1 : loan_id) : loan_id = match_loan_id bid0 bid1 - let match_symbolic_values (sv0 : V.symbolic_value) (sv1 : V.symbolic_value) : - V.symbolic_value = + let match_symbolic_values (sv0 : symbolic_value) (sv1 : symbolic_value) : + symbolic_value = let id0 = sv0.sv_id in let id1 = sv1.sv_id in log#ldebug (lazy ("MakeCheckEquivMatcher: match_symbolic_values: " ^ "sv0: " - ^ V.SymbolicValueId.to_string id0 + ^ SymbolicValueId.to_string id0 ^ ", sv1: " - ^ V.SymbolicValueId.to_string id1)); + ^ SymbolicValueId.to_string id1)); (* If we don't check for equivalence, we also update the map from sids to values *) @@ -916,81 +903,80 @@ struct let sv_id = GetSetSid.match_e "match_symbolic_values: ids: " S.sid_map id0 id1 in - let sv_ty = match_rtys sv0.V.sv_ty sv1.V.sv_ty in + let sv_ty = match_rtys sv0.sv_ty sv1.sv_ty in let sv_kind = - if sv0.V.sv_kind = sv1.V.sv_kind then sv0.V.sv_kind + if sv0.sv_kind = sv1.sv_kind then sv0.sv_kind else raise (Distinct "match_symbolic_values: sv_kind") in - let sv = { V.sv_id; sv_ty; sv_kind } in + let sv = { sv_id; sv_ty; sv_kind } in sv else ( (* Check: fixed values are fixed *) - assert (id0 = id1 || not (V.SymbolicValueId.InjSubst.mem id0 !S.sid_map)); + assert (id0 = id1 || not (SymbolicValueId.InjSubst.mem id0 !S.sid_map)); (* Update the symbolic value mapping *) let sv1 = mk_typed_value_from_symbolic_value sv1 in (* Update the symbolic value mapping *) S.sid_to_value_map := - V.SymbolicValueId.Map.add_strict id0 sv1 !S.sid_to_value_map; + SymbolicValueId.Map.add_strict id0 sv1 !S.sid_to_value_map; (* Return - the returned value is not used: we can return whatever we want *) sv0) - let match_symbolic_with_other (left : bool) (sv : V.symbolic_value) - (v : V.typed_value) : V.typed_value = + let match_symbolic_with_other (left : bool) (sv : symbolic_value) + (v : typed_value) : typed_value = if S.check_equiv then raise (Distinct "match_symbolic_with_other") else ( assert left; let id = sv.sv_id in (* Check: fixed values are fixed *) - assert (not (V.SymbolicValueId.InjSubst.mem id !S.sid_map)); + assert (not (SymbolicValueId.InjSubst.mem id !S.sid_map)); (* Update the binding for the target symbolic value *) S.sid_to_value_map := - V.SymbolicValueId.Map.add_strict id v !S.sid_to_value_map; + SymbolicValueId.Map.add_strict id v !S.sid_to_value_map; (* Return - the returned value is not used, so we can return whatever we want *) v) - let match_bottom_with_other (left : bool) (v : V.typed_value) : V.typed_value - = + let match_bottom_with_other (left : bool) (v : typed_value) : typed_value = (* It can happen that some variables get initialized in some branches and not in some others, which causes problems when matching. *) (* TODO: the returned value is not used, while it should: in generality it should be ok to match a fixed-point with the environment we get at a continue, where the fixed point contains some bottom values. *) - if left && not (value_has_loans_or_borrows S.ctx v.V.value) then - mk_bottom v.V.ty + if left && not (value_has_loans_or_borrows S.ctx v.value) then + mk_bottom v.ty else raise (Distinct "match_bottom_with_other") let match_distinct_aadts _ _ _ _ _ = raise (Distinct "match_distinct_adts") let match_ashared_borrows _ty0 bid0 _ty1 bid1 ty = let bid = match_borrow_id bid0 bid1 in - let value = V.ABorrow (V.ASharedBorrow bid) in - { V.value; ty } + let value = ABorrow (ASharedBorrow bid) in + { value; ty } let match_amut_borrows _ty0 bid0 _av0 _ty1 bid1 _av1 ty av = let bid = match_borrow_id bid0 bid1 in - let value = V.ABorrow (V.AMutBorrow (bid, av)) in - { V.value; ty } + let value = ABorrow (AMutBorrow (bid, av)) in + { value; ty } let match_ashared_loans _ty0 ids0 _v0 _av0 _ty1 ids1 _v1 _av1 ty v av = let bids = match_loan_ids ids0 ids1 in - let value = V.ALoan (V.ASharedLoan (bids, v, av)) in - { V.value; ty } + let value = ALoan (ASharedLoan (bids, v, av)) in + { value; ty } let match_amut_loans _ty0 id0 _av0 _ty1 id1 _av1 ty av = log#ldebug (lazy ("MakeCheckEquivMatcher:match_amut_loans:" ^ "\n- id0: " - ^ V.BorrowId.to_string id0 ^ "\n- id1: " ^ V.BorrowId.to_string id1 - ^ "\n- ty: " ^ PA.ty_to_string S.ctx ty ^ "\n- av: " + ^ BorrowId.to_string id0 ^ "\n- id1: " ^ BorrowId.to_string id1 + ^ "\n- ty: " ^ ty_to_string S.ctx ty ^ "\n- av: " ^ typed_avalue_to_string S.ctx av)); let id = match_loan_id id0 id1 in - let value = V.ALoan (V.AMutLoan (id, av)) in - { V.value; ty } + let value = ALoan (AMutLoan (id, av)) in + { value; ty } let match_avalues v0 v1 = log#ldebug @@ -1003,9 +989,9 @@ struct end let match_ctxs (check_equiv : bool) (fixed_ids : ids_sets) - (lookup_shared_value_in_ctx0 : V.BorrowId.id -> V.typed_value) - (lookup_shared_value_in_ctx1 : V.BorrowId.id -> V.typed_value) - (ctx0 : C.eval_ctx) (ctx1 : C.eval_ctx) : ids_maps option = + (lookup_shared_value_in_ctx0 : BorrowId.id -> typed_value) + (lookup_shared_value_in_ctx1 : BorrowId.id -> typed_value) (ctx0 : eval_ctx) + (ctx1 : eval_ctx) : ids_maps option = log#ldebug (lazy ("match_ctxs:\n\n- fixed_ids:\n" ^ show_ids_sets fixed_ids @@ -1022,35 +1008,35 @@ let match_ctxs (check_equiv : bool) (fixed_ids : ids_sets) (Id.InjSubst.of_list (List.map (fun x -> (x, x)) (Id.Set.elements ids))) end in let rid_map = - let module IdMap = IdMap (T.RegionId) in + let module IdMap = IdMap (RegionId) in IdMap.mk_map_ref fixed_ids.rids in let blid_map = - let module IdMap = IdMap (V.BorrowId) in + let module IdMap = IdMap (BorrowId) in IdMap.mk_map_ref fixed_ids.blids in let borrow_id_map = - let module IdMap = IdMap (V.BorrowId) in + let module IdMap = IdMap (BorrowId) in IdMap.mk_map_ref fixed_ids.borrow_ids in let loan_id_map = - let module IdMap = IdMap (V.BorrowId) in + let module IdMap = IdMap (BorrowId) in IdMap.mk_map_ref fixed_ids.loan_ids in let aid_map = - let module IdMap = IdMap (V.AbstractionId) in + let module IdMap = IdMap (AbstractionId) in IdMap.mk_map_ref fixed_ids.aids in let sid_map = - let module IdMap = IdMap (V.SymbolicValueId) in + let module IdMap = IdMap (SymbolicValueId) in IdMap.mk_map_ref fixed_ids.sids in (* In case we don't try to check equivalence but want to compute a mapping from a source context to a target context, we use a map from symbolic value ids to values (rather than to ids). *) - let sid_to_value_map : V.typed_value V.SymbolicValueId.Map.t ref = - ref V.SymbolicValueId.Map.empty + let sid_to_value_map : typed_value SymbolicValueId.Map.t ref = + ref SymbolicValueId.Map.empty in let module S : MatchCheckEquivState = struct @@ -1074,12 +1060,12 @@ let match_ctxs (check_equiv : bool) (fixed_ids : ids_sets) (* Small utility: check that ids are fixed/mapped to themselves *) let ids_are_fixed (ids : ids_sets) : bool = let { aids; blids = _; borrow_ids; loan_ids; dids; rids; sids } = ids in - V.AbstractionId.Set.subset aids fixed_ids.aids - && V.BorrowId.Set.subset borrow_ids fixed_ids.borrow_ids - && V.BorrowId.Set.subset loan_ids fixed_ids.loan_ids - && C.DummyVarId.Set.subset dids fixed_ids.dids - && T.RegionId.Set.subset rids fixed_ids.rids - && V.SymbolicValueId.Set.subset sids fixed_ids.sids + AbstractionId.Set.subset aids fixed_ids.aids + && BorrowId.Set.subset borrow_ids fixed_ids.borrow_ids + && BorrowId.Set.subset loan_ids fixed_ids.loan_ids + && DummyVarId.Set.subset dids fixed_ids.dids + && RegionId.Set.subset rids fixed_ids.rids + && SymbolicValueId.Set.subset sids fixed_ids.sids in (* We need to pick a context for some functions like [match_typed_values]: @@ -1091,9 +1077,9 @@ let match_ctxs (check_equiv : bool) (fixed_ids : ids_sets) let ctx = ctx0 in (* Rem.: this function raises exceptions of type [Distinct] *) - let match_abstractions (abs0 : V.abs) (abs1 : V.abs) : unit = + let match_abstractions (abs0 : abs) (abs1 : abs) : unit = let { - V.abs_id = abs_id0; + abs_id = abs_id0; kind = kind0; can_end = can_end0; parents = parents0; @@ -1106,7 +1092,7 @@ let match_ctxs (check_equiv : bool) (fixed_ids : ids_sets) in let { - V.abs_id = abs_id1; + abs_id = abs_id1; kind = kind1; can_end = can_end1; parents = parents1; @@ -1137,18 +1123,18 @@ let match_ctxs (check_equiv : bool) (fixed_ids : ids_sets) in (* Rem.: this function raises exceptions of type [Distinct] *) - let rec match_envs (env0 : C.env) (env1 : C.env) : unit = + let rec match_envs (env0 : env) (env1 : env) : unit = log#ldebug (lazy ("match_ctxs: match_envs:\n\n- fixed_ids:\n" ^ show_ids_sets fixed_ids ^ "\n\n- rid_map: " - ^ T.RegionId.InjSubst.show_t !rid_map + ^ RegionId.InjSubst.show_t !rid_map ^ "\n- blid_map: " - ^ V.BorrowId.InjSubst.show_t !blid_map + ^ BorrowId.InjSubst.show_t !blid_map ^ "\n- sid_map: " - ^ V.SymbolicValueId.InjSubst.show_t !sid_map + ^ SymbolicValueId.InjSubst.show_t !sid_map ^ "\n- aid_map: " - ^ V.AbstractionId.InjSubst.show_t !aid_map + ^ AbstractionId.InjSubst.show_t !aid_map ^ "\n\n- ctx0:\n" ^ eval_ctx_to_string_no_filter { ctx0 with env = List.rev env0 } ^ "\n\n- ctx1:\n" @@ -1156,11 +1142,10 @@ let match_ctxs (check_equiv : bool) (fixed_ids : ids_sets) ^ "\n\n")); match (env0, env1) with - | ( C.EBinding (C.BDummy b0, v0) :: env0', - C.EBinding (C.BDummy b1, v1) :: env1' ) -> + | EBinding (BDummy b0, v0) :: env0', EBinding (BDummy b1, v1) :: env1' -> (* Sanity check: if the dummy value is an old value, the bindings must be the same and their values equal (and the borrows/loans/symbolic *) - if C.DummyVarId.Set.mem b0 fixed_ids.dids then ( + if DummyVarId.Set.mem b0 fixed_ids.dids then ( (* Fixed values: the values must be equal *) assert (b0 = b1); assert (v0 = v1); @@ -1171,17 +1156,16 @@ let match_ctxs (check_equiv : bool) (fixed_ids : ids_sets) are the identity actually) *) let _ = M.match_typed_values ctx v0 v1 in match_envs env0' env1' - | C.EBinding (C.BVar b0, v0) :: env0', C.EBinding (C.BVar b1, v1) :: env1' - -> + | EBinding (BVar b0, v0) :: env0', EBinding (BVar b1, v1) :: env1' -> assert (b0 = b1); (* Match the values *) let _ = M.match_typed_values ctx v0 v1 in (* Continue *) match_envs env0' env1' - | C.EAbs abs0 :: env0', C.EAbs abs1 :: env1' -> + | EAbs abs0 :: env0', EAbs abs1 :: env1' -> log#ldebug (lazy "match_ctxs: match_envs: matching abs"); (* Same as for the dummy values: there are two cases *) - if V.AbstractionId.Set.mem abs0.abs_id fixed_ids.aids then ( + if AbstractionId.Set.mem abs0.abs_id fixed_ids.aids then ( log#ldebug (lazy "match_ctxs: match_envs: matching abs: fixed abs"); (* Still in the prefix: the abstractions must be the same *) assert (abs0 = abs1); @@ -1214,7 +1198,7 @@ let match_ctxs (check_equiv : bool) (fixed_ids : ids_sets) let env1 = List.rev ctx1.env in let env0, env1 = match (env0, env1) with - | C.EFrame :: env0, C.EFrame :: env1 -> (env0, env1) + | EFrame :: env0, EFrame :: env1 -> (env0, env1) | _ -> raise (Failure "Unreachable") in @@ -1235,18 +1219,18 @@ let match_ctxs (check_equiv : bool) (fixed_ids : ids_sets) log#ldebug (lazy ("match_ctxs: distinct: " ^ msg)); None -let ctxs_are_equivalent (fixed_ids : ids_sets) (ctx0 : C.eval_ctx) - (ctx1 : C.eval_ctx) : bool = +let ctxs_are_equivalent (fixed_ids : ids_sets) (ctx0 : eval_ctx) + (ctx1 : eval_ctx) : bool = let check_equivalent = true in let lookup_shared_value _ = raise (Failure "Unreachable") in Option.is_some (match_ctxs check_equivalent fixed_ids lookup_shared_value lookup_shared_value ctx0 ctx1) -let match_ctx_with_target (config : C.config) (loop_id : V.LoopId.id) +let match_ctx_with_target (config : config) (loop_id : LoopId.id) (is_loop_entry : bool) (fp_bl_maps : borrow_loan_corresp) - (fp_input_svalues : V.SymbolicValueId.id list) (fixed_ids : ids_sets) - (src_ctx : C.eval_ctx) : st_cm_fun = + (fp_input_svalues : SymbolicValueId.id list) (fixed_ids : ids_sets) + (src_ctx : eval_ctx) : st_cm_fun = fun cf tgt_ctx -> (* Debug *) log#ldebug @@ -1277,7 +1261,7 @@ let match_ctx_with_target (config : C.config) (loop_id : V.LoopId.id) ^ env_to_string tgt_ctx filt_tgt_env)); (* Remove the abstractions *) - let filter (ee : C.env_elem) : bool = + let filter (ee : env_elem) : bool = match ee with EBinding _ -> true | EAbs _ | EFrame -> false in let filt_src_env = List.filter filter filt_src_env in @@ -1307,11 +1291,11 @@ let match_ctx_with_target (config : C.config) (loop_id : V.LoopId.id) List.iter (fun (var0, var1) -> match (var0, var1) with - | C.EBinding (C.BDummy b0, v0), C.EBinding (C.BDummy b1, v1) -> + | EBinding (BDummy b0, v0), EBinding (BDummy b1, v1) -> assert (b0 = b1); let _ = M.match_typed_values ctx v0 v1 in () - | C.EBinding (C.BVar b0, v0), C.EBinding (C.BVar b1, v1) -> + | EBinding (BVar b0, v0), EBinding (BVar b1, v1) -> assert (b0 = b1); let _ = M.match_typed_values ctx v0 v1 in () @@ -1364,7 +1348,7 @@ let match_ctx_with_target (config : C.config) (loop_id : V.LoopId.id) let check_equiv = false in let fixed_ids = ids_sets_empty_borrows_loans fixed_ids in let open InterpreterBorrowsCore in - let lookup_shared_loan lid ctx : V.typed_value = + let lookup_shared_loan lid ctx : typed_value = match snd (lookup_loan ek_all lid ctx) with | Concrete (VSharedLoan (_, v)) -> v | Abstract (ASharedLoan (_, v, _)) -> v @@ -1378,10 +1362,10 @@ let match_ctx_with_target (config : C.config) (loop_id : V.LoopId.id) filt_src_ctx filt_tgt_ctx) in let tgt_to_src_borrow_map = - V.BorrowId.Map.of_list + BorrowId.Map.of_list (List.map (fun (x, y) -> (y, x)) - (V.BorrowId.InjSubst.bindings src_to_tgt_maps.borrow_id_map)) + (BorrowId.InjSubst.bindings src_to_tgt_maps.borrow_id_map)) in (* Debug *) @@ -1395,7 +1379,7 @@ let match_ctx_with_target (config : C.config) (loop_id : V.LoopId.id) ^ eval_ctx_to_string_no_filter filt_src_ctx ^ "\n\n- new_absl:\n" ^ eval_ctx_to_string - { src_ctx with C.env = List.map (fun abs -> C.EAbs abs) new_absl } + { src_ctx with env = List.map (fun abs -> EAbs abs) new_absl } ^ "\n\n- fixed_ids:\n" ^ show_ids_sets fixed_ids ^ "\n\n- fp_bl_maps:\n" ^ show_borrow_loan_corresp fp_bl_maps ^ "\n\n- src_to_tgt_maps: " @@ -1452,26 +1436,26 @@ let match_ctx_with_target (config : C.config) (loop_id : V.LoopId.id) (* First, compute the set of borrows which appear in the fresh abstractions of the fixed-point: we want to introduce fresh ids only for those. *) let new_absl_ids, _ = compute_absl_ids new_absl in - let src_fresh_borrows_map = ref V.BorrowId.Map.empty in + let src_fresh_borrows_map = ref BorrowId.Map.empty in let visit_tgt = object - inherit [_] C.map_eval_ctx + inherit [_] map_eval_ctx method! visit_borrow_id _ id = (* Map the borrow, if it needs to be mapped *) if (* We map the borrows for which we computed a mapping *) - V.BorrowId.InjSubst.Set.mem id - (V.BorrowId.InjSubst.elements src_to_tgt_maps.borrow_id_map) + BorrowId.InjSubst.Set.mem id + (BorrowId.InjSubst.elements src_to_tgt_maps.borrow_id_map) (* And which have corresponding loans in the fresh fixed-point abstractions *) - && V.BorrowId.Set.mem - (V.BorrowId.Map.find id tgt_to_src_borrow_map) + && BorrowId.Set.mem + (BorrowId.Map.find id tgt_to_src_borrow_map) new_absl_ids.loan_ids then ( - let src_id = V.BorrowId.Map.find id tgt_to_src_borrow_map in - let nid = C.fresh_borrow_id () in + let src_id = BorrowId.Map.find id tgt_to_src_borrow_map in + let nid = fresh_borrow_id () in src_fresh_borrows_map := - V.BorrowId.Map.add src_id nid !src_fresh_borrows_map; + BorrowId.Map.add src_id nid !src_fresh_borrows_map; nid) else id end @@ -1482,7 +1466,7 @@ let match_ctx_with_target (config : C.config) (loop_id : V.LoopId.id) (lazy ("match_ctx_with_target: cf_introduce_loop_fp_abs: \ src_fresh_borrows_map:\n" - ^ V.BorrowId.Map.show V.BorrowId.to_string !src_fresh_borrows_map + ^ BorrowId.Map.show BorrowId.to_string !src_fresh_borrows_map ^ "\n")); (* Rem.: we don't update the symbolic values. It is not necessary @@ -1507,48 +1491,44 @@ let match_ctx_with_target (config : C.config) (loop_id : V.LoopId.id) abs@2 { MB l5, ML l6 } ]} *) - let region_id_map = ref T.RegionId.Map.empty in + let region_id_map = ref RegionId.Map.empty in let get_rid rid = - match T.RegionId.Map.find_opt rid !region_id_map with + match RegionId.Map.find_opt rid !region_id_map with | Some rid -> rid | None -> - let nid = C.fresh_region_id () in - region_id_map := T.RegionId.Map.add rid nid !region_id_map; + let nid = fresh_region_id () in + region_id_map := RegionId.Map.add rid nid !region_id_map; nid in let visit_src = object - inherit [_] C.map_eval_ctx as super + inherit [_] map_eval_ctx as super method! visit_borrow_id _ bid = log#ldebug (lazy ("match_ctx_with_target: cf_introduce_loop_fp_abs: \ - visit_borrow_id: " ^ V.BorrowId.to_string bid ^ "\n")); + visit_borrow_id: " ^ BorrowId.to_string bid ^ "\n")); (* Lookup the id of the loan corresponding to this borrow *) let src_lid = - V.BorrowId.InjSubst.find bid fp_bl_maps.borrow_to_loan_id_map + BorrowId.InjSubst.find bid fp_bl_maps.borrow_to_loan_id_map in log#ldebug (lazy ("match_ctx_with_target: cf_introduce_loop_fp_abs: looked up \ - src_lid: " - ^ V.BorrowId.to_string src_lid - ^ "\n")); + src_lid: " ^ BorrowId.to_string src_lid ^ "\n")); (* Lookup the tgt borrow id to which this borrow was mapped *) let tgt_bid = - V.BorrowId.InjSubst.find src_lid src_to_tgt_maps.borrow_id_map + BorrowId.InjSubst.find src_lid src_to_tgt_maps.borrow_id_map in log#ldebug (lazy ("match_ctx_with_target: cf_introduce_loop_fp_abs: looked up \ - tgt_bid: " - ^ V.BorrowId.to_string tgt_bid - ^ "\n")); + tgt_bid: " ^ BorrowId.to_string tgt_bid ^ "\n")); tgt_bid @@ -1556,39 +1536,39 @@ let match_ctx_with_target (config : C.config) (loop_id : V.LoopId.id) log#ldebug (lazy ("match_ctx_with_target: cf_introduce_loop_fp_abs: \ - visit_loan_id: " ^ V.BorrowId.to_string id ^ "\n")); + visit_loan_id: " ^ BorrowId.to_string id ^ "\n")); (* Map the borrow - rem.: we mapped the borrows *in the values*, meaning we know how to map the *corresponding loans in the abstractions* *) - match V.BorrowId.Map.find_opt id !src_fresh_borrows_map with + match BorrowId.Map.find_opt id !src_fresh_borrows_map with | None -> (* No mapping: this means that the borrow was mapped when we matched values (it doesn't come from a fresh abstraction) and because of this, it should actually be mapped to itself *) assert ( - V.BorrowId.InjSubst.find id src_to_tgt_maps.borrow_id_map = id); + BorrowId.InjSubst.find id src_to_tgt_maps.borrow_id_map = id); id | Some id -> id - method! visit_symbolic_value_id _ _ = C.fresh_symbolic_value_id () - method! visit_abstraction_id _ _ = C.fresh_abstraction_id () + method! visit_symbolic_value_id _ _ = fresh_symbolic_value_id () + method! visit_abstraction_id _ _ = fresh_abstraction_id () method! visit_region_id _ id = get_rid id (** We also need to change the abstraction kind *) method! visit_abs env abs = match abs.kind with - | V.Loop (loop_id', rg_id, kind) -> + | Loop (loop_id', rg_id, kind) -> assert (loop_id' = loop_id); - assert (kind = V.LoopSynthInput); + assert (kind = LoopSynthInput); let can_end = false in - let kind = V.Loop (loop_id, rg_id, V.LoopCall) in + let kind : abs_kind = Loop (loop_id, rg_id, LoopCall) in let abs = { abs with kind; can_end } in super#visit_abs env abs | _ -> super#visit_abs env abs end in let new_absl = List.map (visit_src#visit_abs ()) new_absl in - let new_absl = List.map (fun abs -> C.EAbs abs) new_absl in + let new_absl = List.map (fun abs -> EAbs abs) new_absl in (* Add the abstractions from the target context to the source context *) let nenv = List.append new_absl tgt_ctx.env in @@ -1605,19 +1585,17 @@ let match_ctx_with_target (config : C.config) (loop_id : V.LoopId.id) (* End all the borrows which appear in the *new* abstractions *) let new_borrows = - V.BorrowId.Set.of_list - (List.map snd (V.BorrowId.Map.bindings !src_fresh_borrows_map)) + BorrowId.Set.of_list + (List.map snd (BorrowId.Map.bindings !src_fresh_borrows_map)) in let cc = InterpreterBorrows.end_borrows config new_borrows in (* Compute the loop input values *) let input_values = - V.SymbolicValueId.Map.of_list + SymbolicValueId.Map.of_list (List.map (fun sid -> - ( sid, - V.SymbolicValueId.Map.find sid src_to_tgt_maps.sid_to_value_map - )) + (sid, SymbolicValueId.Map.find sid src_to_tgt_maps.sid_to_value_map)) fp_input_svalues) in diff --git a/compiler/InterpreterLoopsMatchCtxs.mli b/compiler/InterpreterLoopsMatchCtxs.mli index 20b997ce..bf29af79 100644 --- a/compiler/InterpreterLoopsMatchCtxs.mli +++ b/compiler/InterpreterLoopsMatchCtxs.mli @@ -4,15 +4,8 @@ to check if two contexts are equivalent (modulo conversion). *) -module T = Types -module PV = PrimitiveValues -module V = Values -module E = Expressions -module C = Contexts -module Subst = Substitute -module A = LlbcAst -module Inv = Invariants -module S = SynthesizeSymbolic +open Values +open Contexts open Cps open InterpreterUtils open InterpreterLoopsCore @@ -26,7 +19,7 @@ open InterpreterLoopsCore - [env] *) val compute_abs_borrows_loans_maps : - bool -> (V.abs -> bool) -> C.env -> abs_borrows_loans_maps + bool -> (abs -> bool) -> env -> abs_borrows_loans_maps (** Generic functor to implement matching functions between values, environments, etc. @@ -100,10 +93,10 @@ module MakeCheckEquivMatcher : functor (_ : MatchCheckEquivState) -> val match_ctxs : bool -> ids_sets -> - (V.loan_id -> V.typed_value) -> - (V.loan_id -> V.typed_value) -> - C.eval_ctx -> - C.eval_ctx -> + (loan_id -> typed_value) -> + (loan_id -> typed_value) -> + eval_ctx -> + eval_ctx -> ids_maps option (** Compute whether two contexts are equivalent modulo an identifier substitution. @@ -142,7 +135,7 @@ val match_ctxs : - [ctx0] - [ctx1] *) -val ctxs_are_equivalent : ids_sets -> C.eval_ctx -> C.eval_ctx -> bool +val ctxs_are_equivalent : ids_sets -> eval_ctx -> eval_ctx -> bool (** Match a context with a target context. @@ -291,11 +284,11 @@ val ctxs_are_equivalent : ids_sets -> C.eval_ctx -> C.eval_ctx -> bool - [src_ctx] *) val match_ctx_with_target : - C.config -> - V.loop_id -> + config -> + loop_id -> bool -> borrow_loan_corresp -> - V.symbolic_value_id list -> + symbolic_value_id list -> ids_sets -> - C.eval_ctx -> + eval_ctx -> st_cm_fun diff --git a/compiler/InterpreterPaths.ml b/compiler/InterpreterPaths.ml index 9158f2c1..729a3577 100644 --- a/compiler/InterpreterPaths.ml +++ b/compiler/InterpreterPaths.ml @@ -1,10 +1,7 @@ -module T = Types -module V = Values -module E = Expressions -module C = Contexts -module Subst = Substitute -module Assoc = AssociatedTypes -module L = Logging +open Types +open Values +open Expressions +open Contexts open Cps open ValuesUtils open InterpreterUtils @@ -14,7 +11,7 @@ open InterpreterExpansion module Synth = SynthesizeSymbolic (** The local logger *) -let log = L.paths_log +let log = Logging.paths_log (** Paths *) @@ -25,26 +22,26 @@ let log = L.paths_log TODO: compare with borrow_lres? *) type path_fail_kind = - | FailSharedLoan of V.BorrowId.Set.t + | FailSharedLoan of BorrowId.Set.t (** Failure because we couldn't go inside a shared loan *) - | FailMutLoan of V.BorrowId.id + | FailMutLoan of BorrowId.id (** Failure because we couldn't go inside a mutable loan *) - | FailReservedMutBorrow of V.BorrowId.id + | FailReservedMutBorrow of BorrowId.id (** Failure because we couldn't go inside a reserved mutable borrow (which should get activated) *) - | FailSymbolic of int * V.symbolic_value + | FailSymbolic of int * 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 + | FailBottom of int * projection_elem * 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 + | FailBorrow of borrow_content (** We got stuck because we couldn't enter a borrow *) [@@deriving show] @@ -56,7 +53,7 @@ type path_fail_kind = 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 updated_read_value = { read : typed_value; updated : typed_value } type projection_access = { enter_shared_loans : bool; @@ -71,10 +68,10 @@ type projection_access = { TODO: use exceptions? *) -let rec access_projection (access : projection_access) (ctx : C.eval_ctx) +let rec access_projection (access : projection_access) (ctx : 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 = + (update : typed_value -> typed_value) (p : projection) (v : typed_value) : + (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 } @@ -86,8 +83,8 @@ let rec access_projection (access : projection_access) (ctx : C.eval_ctx) 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)); + ("Not the same type:\n- nv.ty: " ^ show_ety nv.ty ^ "\n- v.ty: " + ^ show_ety v.ty)); raise (Failure "Assertion failed: new value doesn't have the same type as its \ @@ -106,30 +103,30 @@ let rec access_projection (access : projection_access) (ctx : C.eval_ctx) assert (opt_variant_id = adt.variant_id) | _ -> raise (Failure "Unreachable")); (* Actually project *) - let fv = T.FieldId.nth adt.field_values field_id in + let fv = 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 + FieldId.update_nth adt.field_values field_id res.updated in - let nadt = V.VAdt { adt with field_values = nvalues } in + let nadt = VAdt { adt with field_values = nvalues } in let updated = { v with value = nadt } in Ok (ctx, { res with updated })) (* Tuples *) | Field (ProjTuple arity, field_id), VAdt adt, TAdt (TTuple, _) -> ( assert (arity = List.length adt.field_values); - let fv = T.FieldId.nth adt.field_values field_id in + let fv = 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 + FieldId.update_nth adt.field_values field_id res.updated in - let ntuple = V.VAdt { adt with field_values = nvalues } in + let ntuple = VAdt { 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 @@ -244,9 +241,9 @@ let rec access_projection (access : projection_access) (ctx : C.eval_ctx) else Error (FailSharedLoan bids)) | (_, (VLiteral _ | VAdt _ | VBottom | VBorrow _), _) 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 + let pe = "- pe: " ^ show_projection_elem pe in + let v = "- v:\n" ^ show_value v in + let ty = "- ty:\n" ^ show_ety ty in log#serror ("Inconsistent projection:\n" ^ pe ^ "\n" ^ v ^ "\n" ^ ty); raise (Failure "Inconsistent projection")) @@ -258,16 +255,16 @@ let rec access_projection (access : projection_access) (ctx : C.eval_ctx) *) 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 = + (update : typed_value -> typed_value) (p : place) (ctx : eval_ctx) : + (eval_ctx * typed_value) path_access_result = (* Lookup the variable's value *) - let value = C.ctx_lookup_var_value ctx p.var_id in + let value = 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 + let ctx = ctx_update_var_value ctx p.var_id res.updated in (* Return *) Ok (ctx, res.read) @@ -303,8 +300,8 @@ let access_kind_to_projection_access (access : access_kind) : projection_access 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 try_read_place (access : access_kind) (p : E.place) (ctx : C.eval_ctx) : - V.typed_value path_access_result = +let try_read_place (access : access_kind) (p : place) (ctx : eval_ctx) : + 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 @@ -318,22 +315,21 @@ let try_read_place (access : access_kind) (p : E.place) (ctx : C.eval_ctx) : 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 + ^ show_env ctx1.env ^ "\n\nOld environment:\n" ^ show_env ctx.env in log#serror msg; raise (Failure "Unexpected environment update")); Ok read_value -let read_place (access : access_kind) (p : E.place) (ctx : C.eval_ctx) : - V.typed_value = +let read_place (access : access_kind) (p : place) (ctx : eval_ctx) : typed_value + = match try_read_place access p ctx with | Error e -> raise (Failure ("Unreachable: " ^ show_path_fail_kind e)) | Ok v -> v (** Attempt to update the value at a given place *) -let try_write_place (access : access_kind) (p : E.place) (nv : V.typed_value) - (ctx : C.eval_ctx) : C.eval_ctx path_access_result = +let try_write_place (access : access_kind) (p : place) (nv : typed_value) + (ctx : eval_ctx) : 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 @@ -343,42 +339,42 @@ let try_write_place (access : access_kind) (p : E.place) (nv : V.typed_value) (* We ignore the read value *) Ok ctx -let write_place (access : access_kind) (p : E.place) (nv : V.typed_value) - (ctx : C.eval_ctx) : C.eval_ctx = +let write_place (access : access_kind) (p : place) (nv : typed_value) + (ctx : eval_ctx) : eval_ctx = match try_write_place access p nv ctx with | Error e -> raise (Failure ("Unreachable: " ^ show_path_fail_kind e)) | Ok ctx -> ctx -let compute_expanded_bottom_adt_value (ctx : C.eval_ctx) - (def_id : T.TypeDeclId.id) (opt_variant_id : T.VariantId.id option) - (generics : T.generic_args) : V.typed_value = +let compute_expanded_bottom_adt_value (ctx : eval_ctx) (def_id : TypeDeclId.id) + (opt_variant_id : VariantId.id option) (generics : generic_args) : + typed_value = assert (TypesUtils.generic_args_only_erased_regions generics); (* 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 = C.ctx_lookup_type_decl ctx def_id in - assert (List.length generics.regions = List.length def.T.generics.regions); + let def = ctx_lookup_type_decl ctx def_id in + assert (List.length generics.regions = List.length def.generics.regions); (* Compute the field types *) let field_types = - Assoc.type_decl_get_inst_norm_field_etypes ctx def opt_variant_id generics + AssociatedTypes.type_decl_get_inst_norm_field_etypes ctx def opt_variant_id + generics in (* Initialize the expanded value *) let fields = List.map mk_bottom field_types in - let av = V.VAdt { variant_id = opt_variant_id; field_values = fields } in - let ty = T.TAdt (TAdtId def_id, generics) in - { V.value = av; V.ty } + let av = VAdt { variant_id = opt_variant_id; field_values = fields } in + let ty = TAdt (TAdtId def_id, generics) in + { value = av; ty } -let compute_expanded_bottom_tuple_value (field_types : T.ety list) : - V.typed_value = +let compute_expanded_bottom_tuple_value (field_types : ety list) : typed_value = (* Generate the field values *) let fields = List.map mk_bottom field_types in - let v = V.VAdt { variant_id = None; field_values = fields } in + let v = VAdt { variant_id = None; field_values = fields } in let generics = TypesUtils.mk_generic_args [] field_types [] [] in - let ty = T.TAdt (TTuple, generics) in - { V.value = v; V.ty } + let ty = TAdt (TTuple, generics) in + { value = v; ty } -(** Auxiliary helper to expand {!V.Bottom} values. +(** Auxiliary helper to expand {!Bottom} values. During compilation, rustc desaggregates the ADT initializations. The consequence is that the following rust code: @@ -394,19 +390,19 @@ let compute_expanded_bottom_tuple_value (field_types : T.ety list) : ]} 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 + which are currently {!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 (access : access_kind) (p : E.place) - (remaining_pes : int) (pe : E.projection_elem) (ty : T.ety) - (ctx : C.eval_ctx) : C.eval_ctx = +let expand_bottom_value_from_projection (access : access_kind) (p : place) + (remaining_pes : int) (pe : projection_elem) (ty : ety) (ctx : eval_ctx) : + eval_ctx = (* Debugging *) log#ldebug (lazy ("expand_bottom_value_from_projection:\n" ^ "pe: " - ^ E.show_projection_elem pe ^ "\n" ^ "ty: " ^ T.show_ety ty)); + ^ show_projection_elem pe ^ "\n" ^ "ty: " ^ show_ety ty)); (* Prepare the update: we need to take the proper prefix of the place during whose evaluation we got stuck *) let projection' = @@ -416,41 +412,40 @@ let expand_bottom_value_from_projection (access : access_kind) (p : E.place) 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. + The type of the {!Bottom} value should be a tuple or an AD Note that the projection element we got stuck at should be a - field projection, and gives the variant id if the {!V.Bottom} value + field projection, and gives the variant id if the {!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} + with the proper arity, with all the fields initialized to {!Bottom} *) let nv = match (pe, ty) with (* "Regular" ADTs *) | ( Field (ProjAdt (def_id, opt_variant_id), _), - T.TAdt (TAdtId def_id', generics) ) -> + TAdt (TAdtId def_id', generics) ) -> assert (def_id = def_id'); compute_expanded_bottom_adt_value ctx def_id opt_variant_id generics (* Tuples *) | ( Field (ProjTuple arity, _), - T.TAdt - ( TTuple, - { T.regions = []; types; const_generics = []; trait_refs = [] } ) ) - -> + TAdt + (TTuple, { regions = []; types; const_generics = []; trait_refs = [] }) + ) -> assert (arity = List.length types); (* Generate the field values *) compute_expanded_bottom_tuple_value types | _ -> raise (Failure - ("Unreachable: " ^ E.show_projection_elem pe ^ ", " ^ T.show_ety ty)) + ("Unreachable: " ^ show_projection_elem pe ^ ", " ^ show_ety ty)) in (* Update the context by inserting the expanded value at the proper place *) match try_write_place access p' nv ctx with | Ok ctx -> ctx | Error _ -> raise (Failure "Unreachable") -let rec update_ctx_along_read_place (config : C.config) (access : access_kind) - (p : E.place) : cm_fun = +let rec update_ctx_along_read_place (config : config) (access : access_kind) + (p : place) : cm_fun = fun cf ctx -> (* Attempt to read the place: if it fails, update the environment and retry *) match try_read_place access p ctx with @@ -471,14 +466,14 @@ let rec update_ctx_along_read_place (config : C.config) (access : access_kind) expand_symbolic_value_no_branching config sp (Some (Synth.mk_mplace prefix ctx)) | FailBottom (_, _, _) -> - (* We can't expand {!V.Bottom} values while reading them *) + (* We can't expand {!Bottom} values while reading them *) raise (Failure "Found [Bottom] while reading a place") | FailBorrow _ -> raise (Failure "Could not read a borrow") in comp cc (update_ctx_along_read_place config access p) cf ctx -let rec update_ctx_along_write_place (config : C.config) (access : access_kind) - (p : E.place) : cm_fun = +let rec update_ctx_along_write_place (config : config) (access : access_kind) + (p : 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 *) @@ -496,7 +491,7 @@ let rec update_ctx_along_write_place (config : C.config) (access : access_kind) expand_symbolic_value_no_branching config sp (Some (Synth.mk_mplace p ctx)) | FailBottom (remaining_pes, pe, ty) -> - (* Expand the {!V.Bottom} value *) + (* Expand the {!Bottom} value *) fun cf ctx -> let ctx = expand_bottom_value_from_projection access p remaining_pes pe ty @@ -511,8 +506,8 @@ let rec update_ctx_along_write_place (config : C.config) (access : access_kind) (** Small utility used to break control-flow *) exception UpdateCtx of cm_fun -let rec end_loans_at_place (config : C.config) (access : access_kind) - (p : E.place) : cm_fun = +let rec end_loans_at_place (config : config) (access : access_kind) (p : place) + : cm_fun = fun cf ctx -> (* Iterator to explore a value and update the context whenever we find * loans. @@ -521,7 +516,7 @@ let rec end_loans_at_place (config : C.config) (access : access_kind) * *) let obj = object - inherit [_] V.iter_typed_value as super + inherit [_] iter_typed_value as super method! visit_borrow_content env bc = match bc with @@ -566,20 +561,20 @@ let rec end_loans_at_place (config : C.config) (access : access_kind) * a recursive call to reinspect the value *) comp cc (end_loans_at_place config access p) cf ctx -let drop_outer_loans_at_lplace (config : C.config) (p : E.place) : cm_fun = +let drop_outer_loans_at_lplace (config : config) (p : 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 access p ctx in - let ctx = write_place access p (mk_bottom v.V.ty) ctx in - let dummy_id = C.fresh_dummy_var_id () in - let ctx = C.ctx_push_dummy_var ctx dummy_id v in + let ctx = write_place access p (mk_bottom v.ty) ctx in + let dummy_id = fresh_dummy_var_id () in + let ctx = ctx_push_dummy_var ctx dummy_id v in (* Auxiliary function *) let rec drop : cm_fun = fun cf ctx -> (* Read the value *) - let v = C.ctx_lookup_dummy_var ctx dummy_id in + let v = ctx_lookup_dummy_var ctx dummy_id in (* Check if there are loans or borrows to end *) let with_borrows = false in match get_first_outer_loan_or_borrow_in_value with_borrows v with @@ -603,7 +598,7 @@ let drop_outer_loans_at_lplace (config : C.config) (p : E.place) : cm_fun = let cc = comp cc (fun cf ctx -> (* Pop *) - let ctx, v = C.ctx_remove_dummy_var ctx dummy_id in + let ctx, v = ctx_remove_dummy_var ctx dummy_id in (* Reinsert *) let ctx = write_place access p v ctx in (* Sanity check *) @@ -614,8 +609,8 @@ let drop_outer_loans_at_lplace (config : C.config) (p : E.place) : cm_fun = (* Continue *) cc cf ctx -let prepare_lplace (config : C.config) (p : E.place) - (cf : V.typed_value -> m_fun) : m_fun = +let prepare_lplace (config : config) (p : place) (cf : typed_value -> m_fun) : + m_fun = fun ctx -> log#ldebug (lazy diff --git a/compiler/InterpreterPaths.mli b/compiler/InterpreterPaths.mli index a493ad69..3e29b810 100644 --- a/compiler/InterpreterPaths.mli +++ b/compiler/InterpreterPaths.mli @@ -1,13 +1,8 @@ -module T = Types -module V = Values -module E = Expressions -module C = Contexts -module Subst = Substitute -module Assoc = AssociatedTypes -module L = Logging +open Types +open Values +open Expressions +open Contexts open Cps -open InterpreterExpansion -module Synth = SynthesizeSymbolic type access_kind = Read | Write | Move @@ -18,13 +13,13 @@ type access_kind = Read | Write | Move updates the environment (by ending borrows, expanding symbolic values, etc.) until it manages to fully access the provided place. *) -val update_ctx_along_read_place : C.config -> access_kind -> E.place -> cm_fun +val update_ctx_along_read_place : config -> access_kind -> place -> cm_fun (** Update the environment to be able to write to a place. See {!update_ctx_along_read_place}. *) -val update_ctx_along_write_place : C.config -> access_kind -> E.place -> cm_fun +val update_ctx_along_write_place : config -> access_kind -> place -> cm_fun (** Read the value at a given place. @@ -34,7 +29,7 @@ val update_ctx_along_write_place : C.config -> access_kind -> E.place -> cm_fun 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). *) -val read_place : access_kind -> E.place -> C.eval_ctx -> V.typed_value +val read_place : access_kind -> place -> eval_ctx -> typed_value (** Update the value at a given place. @@ -45,26 +40,25 @@ val read_place : access_kind -> E.place -> C.eval_ctx -> V.typed_value the overwritten value contains borrows, loans, etc. and will simply overwrite it. *) -val write_place : - access_kind -> E.place -> V.typed_value -> C.eval_ctx -> C.eval_ctx +val write_place : access_kind -> place -> typed_value -> eval_ctx -> eval_ctx (** Compute an expanded tuple ⊥ value. [compute_expanded_bottom_tuple_value [ty0, ..., tyn]] returns [(⊥:ty0, ..., ⊥:tyn)] *) -val compute_expanded_bottom_tuple_value : T.ety list -> V.typed_value +val compute_expanded_bottom_tuple_value : ety list -> typed_value (** Compute an expanded ADT ⊥ value. The types in the generics should use erased regions. *) val compute_expanded_bottom_adt_value : - C.eval_ctx -> - T.TypeDeclId.id -> - T.VariantId.id option -> - T.generic_args -> - V.typed_value + eval_ctx -> + TypeDeclId.id -> + VariantId.id option -> + generic_args -> + typed_value (** Drop (end) outer loans at a given place, which should be seen as an l-value (we will write to it later, but need to drop the loans before writing). @@ -79,7 +73,7 @@ val compute_expanded_bottom_adt_value : that the place is *inside* a borrow, if we end the borrow, we won't be able to reinsert the value back). *) -val drop_outer_loans_at_lplace : C.config -> E.place -> cm_fun +val drop_outer_loans_at_lplace : config -> place -> cm_fun (** End the loans at a given place: read the value, if it contains a loan, end this loan, repeat. @@ -90,7 +84,7 @@ val drop_outer_loans_at_lplace : C.config -> E.place -> cm_fun when moving values, we can't move a value which contains loans and thus need to end them, etc. *) -val end_loans_at_place : C.config -> access_kind -> E.place -> cm_fun +val end_loans_at_place : config -> access_kind -> place -> cm_fun (** Small utility. @@ -101,4 +95,4 @@ val end_loans_at_place : C.config -> access_kind -> E.place -> cm_fun place. This value should not contain any outer loan (and we check it is the case). Note that this value is very likely to contain ⊥ subvalues. *) -val prepare_lplace : C.config -> E.place -> (V.typed_value -> m_fun) -> m_fun +val prepare_lplace : config -> place -> (typed_value -> m_fun) -> m_fun diff --git a/compiler/InterpreterProjectors.ml b/compiler/InterpreterProjectors.ml index 8a4b0b4c..4dc53586 100644 --- a/compiler/InterpreterProjectors.ml +++ b/compiler/InterpreterProjectors.ml @@ -1,22 +1,19 @@ -module T = Types -module V = Values -module E = Expressions -module C = Contexts +open Types +open Values +open Contexts module Subst = Substitute module Assoc = AssociatedTypes -module L = Logging open TypesUtils open InterpreterUtils open InterpreterBorrowsCore (** The local logger *) -let log = L.projectors_log +let log = Logging.projectors_log (** [ty] shouldn't contain erased regions *) -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 = +let rec apply_proj_borrows_on_shared_borrow (ctx : eval_ctx) + (fresh_reborrow : BorrowId.id -> BorrowId.id) (regions : RegionId.Set.t) + (v : typed_value) (ty : rty) : abstract_shared_borrows = (* Sanity check - TODO: move those elsewhere (here we perform the check at every * recursive call which is a bit overkill...) *) let ety = Subst.erase_regions ty in @@ -48,14 +45,14 @@ let rec apply_proj_borrows_on_shared_borrow (ctx : C.eval_ctx) let bid, asb = (* Not in the set: dive *) match (bc, kind) with - | VMutBorrow (bid, bv), Mut -> + | VMutBorrow (bid, bv), RMut -> (* 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) - | VSharedBorrow bid, Shared -> + | VSharedBorrow bid, RShared -> (* Lookup the shared value *) let ek = ek_all in let sv = lookup_loan ek bid ctx in @@ -79,33 +76,32 @@ let rec apply_proj_borrows_on_shared_borrow (ctx : C.eval_ctx) * we never project over static regions) *) if region_in_set r regions then let bid' = fresh_reborrow bid in - V.AsbBorrow bid' :: asb + AsbBorrow bid' :: asb else asb in asb | VLoan _, _ -> raise (Failure "Unreachable") | VSymbolic 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) ] + assert (not (projections_intersect s.sv_ty ctx.ended_regions ty regions)); + [ AsbProjReborrows (s, ty) ] | _ -> raise (Failure "Unreachable") -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 = +let rec apply_proj_borrows (check_symbolic_no_ended : bool) (ctx : eval_ctx) + (fresh_reborrow : BorrowId.id -> BorrowId.id) (regions : RegionId.Set.t) + (ancestors_regions : RegionId.Set.t) (v : typed_value) (ty : rty) : + 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 (ty_is_rty ty && ety = v.V.ty); + assert (ty_is_rty ty && ety = 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 } + if not (ty_has_regions_in_set regions ty) then { value = AIgnored; ty } else - let value : V.avalue = + let value : avalue = match (v.value, ty) with - | VLiteral _, T.TLiteral _ -> V.AIgnored - | VAdt adt, T.TAdt (id, generics) -> + | VLiteral _, TLiteral _ -> AIgnored + | VAdt adt, TAdt (id, generics) -> (* Retrieve the types of the fields *) let field_types = Assoc.ctx_adt_value_get_inst_norm_field_rtypes ctx adt id generics @@ -119,7 +115,7 @@ let rec apply_proj_borrows (check_symbolic_no_ended : bool) (ctx : C.eval_ctx) regions ancestors_regions fv fty) fields_types in - V.AAdt { variant_id = adt.variant_id; field_values = proj_fields } + AAdt { variant_id = adt.variant_id; field_values = proj_fields } | VBottom, _ -> raise (Failure "Unreachable") | VBorrow bc, TRef (r, ref_ty, kind) -> if @@ -130,14 +126,14 @@ let rec apply_proj_borrows (check_symbolic_no_ended : bool) (ctx : C.eval_ctx) (* In the set *) let bc = match (bc, kind) with - | VMutBorrow (bid, bv), T.Mut -> + | VMutBorrow (bid, bv), RMut -> (* 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 (bid, bv) - | VSharedBorrow bid, T.Shared -> + AMutBorrow (bid, bv) + | VSharedBorrow bid, RShared -> (* Rem.: we don't need to also apply the projection on the borrowed value, because for as long as the abstraction lives then the shared borrow lives, which means that the @@ -149,7 +145,7 @@ let rec apply_proj_borrows (check_symbolic_no_ended : bool) (ctx : C.eval_ctx) need to lookup the shared value and project it (see the other branch of the [if then else]). *) - V.ASharedBorrow bid + ASharedBorrow bid | VReservedMutBorrow _, _ -> raise (Failure @@ -157,14 +153,14 @@ let rec apply_proj_borrows (check_symbolic_no_ended : bool) (ctx : C.eval_ctx) borrow") | _ -> raise (Failure "Unreachable") in - V.ABorrow bc + ABorrow bc else (* Not in the set: ignore the borrow, but project the borrowed value (maybe some borrows *inside* the borrowed value are in the region set) *) let bc = match (bc, kind) with - | VMutBorrow (bid, bv), T.Mut -> + | VMutBorrow (bid, bv), RMut -> (* Apply the projection on the borrowed value *) let bv = apply_proj_borrows check_symbolic_no_ended ctx @@ -176,8 +172,8 @@ let rec apply_proj_borrows (check_symbolic_no_ended : bool) (ctx : C.eval_ctx) if region_in_set r ancestors_regions then Some bid else None in (* Return *) - V.AIgnoredMutBorrow (opt_bid, bv) - | VSharedBorrow bid, T.Shared -> + AIgnoredMutBorrow (opt_bid, bv) + | VSharedBorrow bid, RShared -> (* Lookup the shared value *) let ek = ek_all in let sv = lookup_loan ek bid ctx in @@ -189,7 +185,7 @@ let rec apply_proj_borrows (check_symbolic_no_ended : bool) (ctx : C.eval_ctx) regions sv ref_ty | _ -> raise (Failure "Unexpected") in - V.AProjSharedBorrow asb + AProjSharedBorrow asb | VReservedMutBorrow _, _ -> raise (Failure @@ -197,7 +193,7 @@ let rec apply_proj_borrows (check_symbolic_no_ended : bool) (ctx : C.eval_ctx) borrow") | _ -> raise (Failure "Unreachable") in - V.ABorrow bc + ABorrow bc | VLoan _, _ -> raise (Failure "Unreachable") | VSymbolic s, _ -> (* Check that the projection doesn't contain already ended regions, @@ -209,48 +205,48 @@ let rec apply_proj_borrows (check_symbolic_no_ended : bool) (ctx : C.eval_ctx) let rset2 = regions in log#ldebug (lazy - ("projections_intersect:" ^ "\n- ty1: " - ^ PA.ty_to_string ctx ty1 ^ "\n- rset1: " - ^ T.RegionId.Set.to_string None rset1 - ^ "\n- ty2: " ^ PA.ty_to_string ctx ty2 ^ "\n- rset2: " - ^ T.RegionId.Set.to_string None rset2 + ("projections_intersect:" ^ "\n- ty1: " ^ ty_to_string ctx ty1 + ^ "\n- rset1: " + ^ RegionId.Set.to_string None rset1 + ^ "\n- ty2: " ^ ty_to_string ctx ty2 ^ "\n- rset2: " + ^ RegionId.Set.to_string None rset2 ^ "\n")); assert (not (projections_intersect ty1 rset1 ty2 rset2))); - V.ASymbolic (AProjBorrows (s, ty)) + ASymbolic (AProjBorrows (s, ty)) | _ -> log#lerror (lazy ("apply_proj_borrows: unexpected inputs:\n- input value: " ^ typed_value_to_string ctx v - ^ "\n- proj rty: " ^ PA.ty_to_string ctx ty)); + ^ "\n- proj rty: " ^ ty_to_string ctx ty)); raise (Failure "Unreachable") in { value; ty } -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 symbolic_expansion_non_borrow_to_value (sv : symbolic_value) + (see : symbolic_expansion) : typed_value = + let ty = Subst.erase_regions sv.sv_ty in let value = match see with - | SeLiteral cv -> V.VLiteral cv + | SeLiteral cv -> VLiteral cv | SeAdt (variant_id, field_values) -> let field_values = List.map mk_typed_value_from_symbolic_value field_values in - V.VAdt { V.variant_id; V.field_values } + VAdt { variant_id; field_values } | SeMutRef (_, _) | SeSharedRef (_, _) -> raise (Failure "Unexpected symbolic reference expansion") in - { V.value; V.ty } + { value; ty } -let symbolic_expansion_non_shared_borrow_to_value (sv : V.symbolic_value) - (see : V.symbolic_expansion) : V.typed_value = +let symbolic_expansion_non_shared_borrow_to_value (sv : symbolic_value) + (see : symbolic_expansion) : typed_value = match see with | SeMutRef (bid, bv) -> - let ty = Subst.erase_regions sv.V.sv_ty in + let ty = Subst.erase_regions sv.sv_ty in let bv = mk_typed_value_from_symbolic_value bv in - let value = V.VBorrow (VMutBorrow (bid, bv)) in - { V.value; ty } + let value = VBorrow (VMutBorrow (bid, bv)) in + { value; ty } | SeSharedRef (_, _) -> raise (Failure "Unexpected symbolic shared reference expansion") | _ -> symbolic_expansion_non_borrow_to_value sv see @@ -259,34 +255,34 @@ let symbolic_expansion_non_shared_borrow_to_value (sv : V.symbolic_value) TODO: detailed comments. See [apply_proj_borrows] *) -let apply_proj_loans_on_symbolic_expansion (regions : T.RegionId.Set.t) - (ancestors_regions : T.RegionId.Set.t) (see : V.symbolic_expansion) - (original_sv_ty : T.rty) : V.typed_avalue = +let apply_proj_loans_on_symbolic_expansion (regions : RegionId.Set.t) + (ancestors_regions : RegionId.Set.t) (see : symbolic_expansion) + (original_sv_ty : rty) : 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.ty = + let (value, ty) : avalue * ty = match (see, original_sv_ty) with - | SeLiteral _, T.TLiteral _ -> (V.AIgnored, original_sv_ty) - | SeAdt (variant_id, field_values), T.TAdt (_id, _generics) -> + | SeLiteral _, TLiteral _ -> (AIgnored, original_sv_ty) + | SeAdt (variant_id, field_values), TAdt (_id, _generics) -> (* 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), TRef (r, ref_ty, T.Mut) -> + (AAdt { variant_id; field_values }, original_sv_ty) + | SeMutRef (bid, spc), TRef (r, ref_ty, RMut) -> (* Sanity check *) - assert (spc.V.sv_ty = ref_ty); + assert (spc.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) + (ALoan (AMutLoan (bid, child_av)), ref_ty) else (* Not in the set: ignore *) (* If the borrow id is in the ancestor's regions, we still need @@ -294,10 +290,10 @@ let apply_proj_loans_on_symbolic_expansion (regions : T.RegionId.Set.t) let opt_bid = if region_in_set r ancestors_regions then Some bid else None in - (V.ALoan (V.AIgnoredMutLoan (opt_bid, child_av)), ref_ty) - | SeSharedRef (bids, spc), TRef (r, ref_ty, T.Shared) -> + (ALoan (AIgnoredMutLoan (opt_bid, child_av)), ref_ty) + | SeSharedRef (bids, spc), TRef (r, ref_ty, RShared) -> (* Sanity check *) - assert (spc.V.sv_ty = ref_ty); + assert (spc.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 @@ -305,13 +301,13 @@ let apply_proj_loans_on_symbolic_expansion (regions : T.RegionId.Set.t) 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) + (ALoan (ASharedLoan (bids, shared_value, child_av)), ref_ty) else (* Not in the set: ignore *) - (V.ALoan (V.AIgnoredSharedLoan child_av), ref_ty) + (ALoan (AIgnoredSharedLoan child_av), ref_ty) | _ -> raise (Failure "Unreachable") in - { V.value; V.ty } + { value; ty } (** Auxiliary function. See [give_back_value]. @@ -335,8 +331,8 @@ let apply_proj_loans_on_symbolic_expansion (regions : T.RegionId.Set.t) 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 = +let apply_reborrows (reborrows : (BorrowId.id * BorrowId.id) list) + (ctx : eval_ctx) : 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. @@ -345,7 +341,7 @@ let apply_reborrows (reborrows : (V.BorrowId.id * V.BorrowId.id) list) (* 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 = + let get_borrow_in_mut_borrow (v : typed_value) : BorrowId.id option = match v.value with | VBorrow lc -> ( match lc with @@ -358,12 +354,12 @@ let apply_reborrows (reborrows : (V.BorrowId.id * V.BorrowId.id) list) let insert_reborrows bids = (* Find the reborrows to apply *) let insert, reborrows' = - List.partition (fun (bid, _) -> V.BorrowId.Set.mem bid bids) !reborrows + List.partition (fun (bid, _) -> 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 + List.fold_left (fun bids bid -> BorrowId.Set.add bid bids) bids insert in (* Get the list of reborrows for a given borrow id *) @@ -378,8 +374,8 @@ let apply_reborrows (reborrows : (V.BorrowId.id * V.BorrowId.id) list) let borrows_to_set bids = List.fold_left - (fun bids bid -> V.BorrowId.Set.add bid bids) - V.BorrowId.Set.empty bids + (fun bids bid -> BorrowId.Set.add bid bids) + BorrowId.Set.empty bids in (* Insert reborrows for a given borrow id into a given set of borrows *) @@ -387,12 +383,12 @@ let apply_reborrows (reborrows : (V.BorrowId.id * V.BorrowId.id) list) (* 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 + List.fold_left (fun bids bid -> BorrowId.Set.add bid bids) bids insert in let obj = object - inherit [_] C.map_eval_ctx as super + inherit [_] map_eval_ctx as super (** We may need to reborrow mutable borrows. Note that this doesn't happen for aborrows *) @@ -407,9 +403,9 @@ let apply_reborrows (reborrows : (V.BorrowId.id * V.BorrowId.id) list) else (* There are reborrows: insert a shared loan *) let insert = borrows_to_set insert in - let value = V.VLoan (VSharedLoan (insert, nbc)) in + let value = VLoan (VSharedLoan (insert, nbc)) in let ty = v.ty in - { V.value; ty } + { value; ty } | _ -> super#visit_typed_value env v (** We reimplement {!visit_loan_content} (rather than one of the sub- @@ -471,33 +467,33 @@ let apply_reborrows (reborrows : (V.BorrowId.id * V.BorrowId.id) list) (* Return *) ctx -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 +let prepare_reborrows (config : config) (allow_reborrows : bool) : + (BorrowId.id -> BorrowId.id) * (eval_ctx -> eval_ctx) = + let reborrows : (BorrowId.id * BorrowId.id) list ref = ref [] in (* The function to generate and register fresh reborrows *) - let fresh_reborrow (bid : V.BorrowId.id) : V.BorrowId.id = + let fresh_reborrow (bid : BorrowId.id) : BorrowId.id = if allow_reborrows then ( - let bid' = C.fresh_borrow_id () in + let bid' = fresh_borrow_id () in reborrows := (bid, bid') :: !reborrows; bid') else raise (Failure "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 -> + let apply_registered_reborrows (ctx : eval_ctx) : eval_ctx = + match config.mode with + | ConcreteMode -> assert (!reborrows = []); ctx - | C.SymbolicMode -> + | SymbolicMode -> (* Apply the reborrows *) apply_reborrows !reborrows ctx in (fresh_reborrow, apply_registered_reborrows) (** [ty] shouldn't have erased regions *) -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 apply_proj_borrows_on_input_value (config : config) (ctx : eval_ctx) + (regions : RegionId.Set.t) (ancestors_regions : RegionId.Set.t) + (v : typed_value) (ty : rty) : eval_ctx * typed_avalue = assert (ty_is_rty ty); let check_symbolic_no_ended = true in let allow_reborrows = true in diff --git a/compiler/InterpreterProjectors.mli b/compiler/InterpreterProjectors.mli index 7cee9ee7..583c6907 100644 --- a/compiler/InterpreterProjectors.mli +++ b/compiler/InterpreterProjectors.mli @@ -1,16 +1,12 @@ -module T = Types -module V = Values -module E = Expressions -module C = Contexts -module Subst = Substitute -module L = Logging -open InterpreterBorrowsCore +open Types +open Values +open Contexts (** Auxiliary function. Apply a proj_borrows on a shared borrow. Note that when projecting over shared values, we generate - {!type:V.abstract_shared_borrows}, not {!type:V.avalue}s. + {!type:abstract_shared_borrows}, not {!type:avalue}s. Parameters: [regions] @@ -19,15 +15,11 @@ open InterpreterBorrowsCore [original_sv_ty]: shouldn't have erased regions *) val apply_proj_loans_on_symbolic_expansion : - T.RegionId.Set.t -> - T.RegionId.Set.t -> - V.symbolic_expansion -> - T.rty -> - V.typed_avalue + RegionId.Set.t -> RegionId.Set.t -> symbolic_expansion -> rty -> typed_avalue (** Convert a symbolic expansion *which is not a borrow* to a value *) val symbolic_expansion_non_borrow_to_value : - V.symbolic_value -> V.symbolic_expansion -> V.typed_value + symbolic_value -> symbolic_expansion -> typed_value (** Convert a symbolic expansion *which is not a shared borrow* to a value. @@ -36,7 +28,7 @@ val symbolic_expansion_non_borrow_to_value : during a symbolic expansion. *) val symbolic_expansion_non_shared_borrow_to_value : - V.symbolic_value -> V.symbolic_expansion -> V.typed_value + symbolic_value -> symbolic_expansion -> typed_value (** Auxiliary function to prepare reborrowing operations (used when applying projectors). @@ -51,9 +43,7 @@ val symbolic_expansion_non_shared_borrow_to_value : - [allow_reborrows] *) val prepare_reborrows : - C.config -> - bool -> - (V.BorrowId.id -> V.BorrowId.id) * (C.eval_ctx -> C.eval_ctx) + config -> bool -> (BorrowId.id -> BorrowId.id) * (eval_ctx -> eval_ctx) (** Apply (and reduce) a projector over borrows to an avalue. We use this for instance to spread the borrows present in the inputs @@ -107,13 +97,13 @@ val prepare_reborrows : *) val apply_proj_borrows : bool -> - C.eval_ctx -> - (V.BorrowId.id -> V.BorrowId.id) -> - T.RegionId.Set.t -> - T.RegionId.Set.t -> - V.typed_value -> - T.rty -> - V.typed_avalue + eval_ctx -> + (BorrowId.id -> BorrowId.id) -> + RegionId.Set.t -> + RegionId.Set.t -> + typed_value -> + rty -> + typed_avalue (** Parameters: - [config] @@ -125,10 +115,10 @@ val apply_proj_borrows : erased regions) *) val apply_proj_borrows_on_input_value : - C.config -> - C.eval_ctx -> - T.RegionId.Set.t -> - T.RegionId.Set.t -> - V.typed_value -> - T.rty -> - C.eval_ctx * V.typed_avalue + config -> + eval_ctx -> + RegionId.Set.t -> + RegionId.Set.t -> + typed_value -> + rty -> + eval_ctx * typed_avalue diff --git a/compiler/InterpreterStatements.ml b/compiler/InterpreterStatements.ml index b78c2691..88130f21 100644 --- a/compiler/InterpreterStatements.ml +++ b/compiler/InterpreterStatements.ml @@ -1,28 +1,25 @@ -module T = Types -module PV = PrimitiveValues -module V = Values -module E = Expressions -module C = Contexts -module Subst = Substitute -module A = LlbcAst -module L = Logging +open Types open TypesUtils +open PrimitiveValues +open Values open ValuesUtils -module Inv = Invariants -module S = SynthesizeSymbolic +open Expressions +open Contexts +open LlbcAst open Cps open InterpreterUtils open InterpreterProjectors open InterpreterExpansion open InterpreterPaths open InterpreterExpressions -module PCtx = Print.EvalCtxLlbcAst +module Subst = Substitute +module S = SynthesizeSymbolic (** 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 = +let drop_value (config : config) (p : place) : cm_fun = fun cf ctx -> log#ldebug (lazy @@ -36,12 +33,12 @@ let drop_value (config : C.config) (p : E.place) : cm_fun = (* Prepare the place (by ending the outer loans *at* the place). *) let cc = comp cc (prepare_lplace config p) in (* Replace the value with {!Bottom} *) - let replace cf (v : V.typed_value) ctx = + let replace cf (v : typed_value) ctx = (* Move the value at destination (that we will overwrite) to a dummy variable * to preserve the borrows it may contain *) let mv = InterpreterPaths.read_place access p ctx in - let dummy_id = C.fresh_dummy_var_id () in - let ctx = C.ctx_push_dummy_var ctx dummy_id mv in + let dummy_id = fresh_dummy_var_id () in + let ctx = ctx_push_dummy_var ctx dummy_id mv in (* Update the destination to ⊥ *) let nv = { v with value = VBottom } in let ctx = write_place access p nv ctx in @@ -55,40 +52,39 @@ let drop_value (config : C.config) (p : E.place) : cm_fun = comp cc replace cf ctx (** Push a dummy variable to the environment *) -let push_dummy_var (vid : C.DummyVarId.id) (v : V.typed_value) : cm_fun = +let push_dummy_var (vid : DummyVarId.id) (v : typed_value) : cm_fun = fun cf ctx -> - let ctx = C.ctx_push_dummy_var ctx vid v in + let ctx = ctx_push_dummy_var ctx vid v in cf ctx (** Remove a dummy variable from the environment *) -let remove_dummy_var (vid : C.DummyVarId.id) (cf : V.typed_value -> m_fun) : - m_fun = +let remove_dummy_var (vid : DummyVarId.id) (cf : typed_value -> m_fun) : m_fun = fun ctx -> - let ctx, v = C.ctx_remove_dummy_var ctx vid in + let ctx, v = ctx_remove_dummy_var ctx vid in cf v ctx (** Push an uninitialized variable to the environment *) -let push_uninitialized_var (var : A.var) : cm_fun = +let push_uninitialized_var (var : var) : cm_fun = fun cf ctx -> - let ctx = C.ctx_push_uninitialized_var ctx var in + let ctx = 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 = +let push_uninitialized_vars (vars : var list) : cm_fun = fun cf ctx -> - let ctx = C.ctx_push_uninitialized_vars ctx vars in + let ctx = 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 = +let push_var (var : var) (v : typed_value) : cm_fun = fun cf ctx -> - let ctx = C.ctx_push_var ctx var v in + let ctx = 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 = +let push_vars (vars : (var * typed_value) list) : cm_fun = fun cf ctx -> - let ctx = C.ctx_push_vars ctx vars in + let ctx = ctx_push_vars ctx vars in cf ctx (** Assign a value to a given place. @@ -98,8 +94,7 @@ let push_vars (vars : (A.var * V.typed_value) list) : cm_fun = 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 = +let assign_to_place (config : config) (rv : typed_value) (p : place) : cm_fun = fun cf ctx -> log#ldebug (lazy @@ -108,20 +103,20 @@ let assign_to_place (config : C.config) (rv : V.typed_value) (p : E.place) : ^ "\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 rvalue_vid = C.fresh_dummy_var_id () in + let rvalue_vid = fresh_dummy_var_id () in let cc = push_dummy_var rvalue_vid rv in (* Prepare the destination *) let cc = comp cc (prepare_lplace config p) in (* Retrieve the rvalue from the dummy variable *) let cc = comp cc (fun cf _lv -> remove_dummy_var rvalue_vid cf) in (* Update the destination *) - let move_dest cf (rv : V.typed_value) : m_fun = + let move_dest cf (rv : 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 = InterpreterPaths.read_place Write p ctx in - let dest_vid = C.fresh_dummy_var_id () in - let ctx = C.ctx_push_dummy_var ctx dest_vid mv in + let dest_vid = fresh_dummy_var_id () in + let ctx = ctx_push_dummy_var ctx dest_vid 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)); @@ -141,12 +136,12 @@ let assign_to_place (config : C.config) (rv : V.typed_value) (p : E.place) : 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) : +let eval_assertion_concrete (config : config) (assertion : 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 = + let eval_assert cf (v : typed_value) : m_fun = fun ctx -> match v.value with | VLiteral (VBool b) -> @@ -165,12 +160,12 @@ let eval_assertion_concrete (config : C.config) (assertion : A.assertion) : 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 = +let eval_assertion (config : config) (assertion : 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 = + let eval_assert cf (v : typed_value) : m_fun = fun ctx -> assert (v.ty = TLiteral TBool); (* We make a choice here: we could completely decouple the concrete and @@ -210,26 +205,26 @@ let eval_assertion (config : C.config) (assertion : A.assertion) : st_cm_fun = - 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 + one, or the value is actually {!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}. + a variant with all its fields set to {!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 = +let set_discriminant (config : config) (p : place) (variant_id : 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 + ^ 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 cc = comp cc (prepare_lplace config p) in (* Update the value *) - let update_value cf (v : V.typed_value) : m_fun = + let update_value cf (v : typed_value) : m_fun = fun ctx -> match (v.ty, v.value) with | TAdt ((TAdtId _ as type_id), generics), VAdt av -> ( @@ -281,7 +276,7 @@ let set_discriminant (config : C.config) (p : E.place) 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 = +let ctx_push_frame (ctx : eval_ctx) : eval_ctx = { ctx with env = EFrame :: ctx.env } (** Push a frame delimiter in the context's environment *) @@ -290,8 +285,8 @@ 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 an assumed function. *) -let get_assumed_function_return_type (ctx : C.eval_ctx) (fid : A.assumed_fun_id) - (generics : T.generic_args) : T.ety = +let get_assumed_function_return_type (ctx : eval_ctx) (fid : assumed_fun_id) + (generics : generic_args) : ety = assert (generics.trait_refs = []); (* [Box::free] has a special treatment *) match fid with @@ -305,7 +300,7 @@ let get_assumed_function_return_type (ctx : C.eval_ctx) (fid : A.assumed_fun_id) let sg = Assumed.get_assumed_fun_sig fid in (* Instantiate the return type *) (* There shouldn't be any reference to Self *) - let tr_self : T.trait_instance_id = T.UnknownTrait __FUNCTION__ in + let tr_self : trait_instance_id = UnknownTrait __FUNCTION__ in let generics = Subst.generic_args_erase_regions generics in let { Subst.r_subst = _; ty_subst; cg_subst; tr_subst; tr_self } = Subst.make_subst_from_generics sg.generics generics tr_self @@ -314,41 +309,41 @@ let get_assumed_function_return_type (ctx : C.eval_ctx) (fid : A.assumed_fun_id) Subst.erase_regions_substitute_types ty_subst cg_subst tr_subst tr_self sg.output in - Assoc.ctx_normalize_erase_ty ctx ty + AssociatedTypes.ctx_normalize_erase_ty ctx ty -let move_return_value (config : C.config) (pop_return_value : bool) - (cf : V.typed_value option -> m_fun) : m_fun = +let move_return_value (config : config) (pop_return_value : bool) + (cf : typed_value option -> m_fun) : m_fun = fun ctx -> if pop_return_value then - let ret_vid = E.VarId.zero in - let cc = eval_operand config (E.Move (mk_place_from_var_id ret_vid)) in + let ret_vid = VarId.zero in + let cc = eval_operand config (Move (mk_place_from_var_id ret_vid)) in cc (fun v ctx -> cf (Some v) ctx) ctx else cf None ctx -let pop_frame (config : C.config) (pop_return_value : bool) - (cf : V.typed_value option -> m_fun) : m_fun = +let pop_frame (config : config) (pop_return_value : bool) + (cf : typed_value option -> m_fun) : m_fun = fun ctx -> (* Debug *) log#ldebug (lazy ("pop_frame:\n" ^ eval_ctx_to_string ctx)); (* List the local variables, but the return variable *) - let ret_vid = E.VarId.zero in + let ret_vid = VarId.zero in let rec list_locals env = match env with | [] -> raise (Failure "Inconsistent environment") - | C.EAbs _ :: env -> list_locals env - | C.EBinding (BDummy _, _) :: env -> list_locals env - | C.EBinding (BVar var, _) :: env -> + | EAbs _ :: env -> list_locals env + | EBinding (BDummy _, _) :: env -> list_locals env + | EBinding (BVar var, _) :: env -> let locals = list_locals env in if var.index <> ret_vid then var.index :: locals else locals - | C.EFrame :: _ -> [] + | EFrame :: _ -> [] in - let locals : E.VarId.id list = list_locals ctx.env in + let locals : VarId.id list = list_locals ctx.env in (* Debug *) log#ldebug (lazy ("pop_frame: locals in which to drop the outer loans: [" - ^ String.concat "," (List.map E.VarId.to_string locals) + ^ String.concat "," (List.map VarId.to_string locals) ^ "]")); (* Move the return value out of the return variable *) @@ -363,7 +358,7 @@ let pop_frame (config : C.config) (pop_return_value : bool) in (* Drop the outer *loans* we find in the local variables *) - let cf_drop_loans_in_locals cf (ret_value : V.typed_value option) : m_fun = + let cf_drop_loans_in_locals cf (ret_value : typed_value option) : m_fun = (* Drop the loans *) let locals = List.rev locals in let cf_drop = @@ -391,13 +386,13 @@ let pop_frame (config : C.config) (pop_return_value : bool) let rec pop env = match env with | [] -> raise (Failure "Inconsistent environment") - | C.EAbs abs :: env -> C.EAbs abs :: pop env - | C.EBinding (_, v) :: env -> - let vid = C.fresh_dummy_var_id () in - C.EBinding (C.BDummy vid, v) :: pop env - | C.EFrame :: env -> (* Stop here *) env + | EAbs abs :: env -> EAbs abs :: pop env + | EBinding (_, v) :: env -> + let vid = fresh_dummy_var_id () in + EBinding (BDummy vid, v) :: pop env + | EFrame :: env -> (* Stop here *) env in - let cf_pop cf (ret_value : V.typed_value option) : m_fun = + let cf_pop cf (ret_value : typed_value option) : m_fun = fun ctx -> let env = pop ctx.env in let ctx = { ctx with env } in @@ -407,7 +402,7 @@ let pop_frame (config : C.config) (pop_return_value : bool) 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 pop_frame_assign (config : config) (dest : place) : cm_fun = let cf_pop = pop_frame config true in let cf_assign cf ret_value : m_fun = assign_to_place config (Option.get ret_value) dest cf @@ -415,8 +410,7 @@ let pop_frame_assign (config : C.config) (dest : E.place) : cm_fun = comp cf_pop cf_assign (** Auxiliary function - see {!eval_assumed_function_call} *) -let eval_box_new_concrete (config : C.config) (generics : T.generic_args) : - cm_fun = +let eval_box_new_concrete (config : config) (generics : generic_args) : cm_fun = fun cf ctx -> (* Check and retrieve the arguments *) match @@ -427,27 +421,27 @@ let eval_box_new_concrete (config : C.config) (generics : T.generic_args) : [], EBinding (BVar input_var, input_value) :: EBinding (_ret_var, _) - :: C.EFrame :: _ ) -> + :: EFrame :: _ ) -> (* Required type checking *) - assert (input_value.V.ty = boxed_ty); + assert (input_value.ty = boxed_ty); (* Move the input value *) let cf_move = - eval_operand config (E.Move (mk_place_from_var_id input_var.C.index)) + eval_operand config (Move (mk_place_from_var_id input_var.index)) in (* Create the new box *) - let cf_create cf (moved_input_value : V.typed_value) : m_fun = + let cf_create cf (moved_input_value : typed_value) : m_fun = (* Create the box value *) let generics = TypesUtils.mk_generic_args_from_types [ boxed_ty ] in - let box_ty = T.TAdt (T.TAssumed T.TBox, generics) in + let box_ty = TAdt (TAssumed TBox, generics) in let box_v = - V.VAdt { variant_id = None; field_values = [ moved_input_value ] } + VAdt { 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 E.VarId.zero in + let dest = mk_place_from_var_id VarId.zero in let cf_assign = assign_to_place config box_v dest in (* Continue *) @@ -477,14 +471,14 @@ let eval_box_new_concrete (config : C.config) (generics : T.generic_args) : 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) (generics : T.generic_args) - (args : E.operand list) (dest : E.place) : cm_fun = +let eval_box_free (config : config) (generics : generic_args) + (args : operand list) (dest : place) : cm_fun = fun cf ctx -> match (generics.regions, generics.types, generics.const_generics, args) with - | [], [ boxed_ty ], [], [ E.Move input_box_place ] -> + | [], [ boxed_ty ], [], [ Move input_box_place ] -> (* Required type checking *) let input_box = InterpreterPaths.read_place Write input_box_place ctx in - (let input_ty = ty_get_box input_box.V.ty in + (let input_ty = ty_get_box input_box.ty in assert (input_ty = boxed_ty)); (* Drop the value *) @@ -498,8 +492,8 @@ let eval_box_free (config : C.config) (generics : T.generic_args) | _ -> raise (Failure "Inconsistent state") (** Evaluate a non-local function call in concrete mode *) -let eval_assumed_function_call_concrete (config : C.config) - (fid : A.assumed_fun_id) (call : A.call) : cm_fun = +let eval_assumed_function_call_concrete (config : config) (fid : assumed_fun_id) + (call : call) : cm_fun = let generics = call.func.generics in let args = call.args in let dest = call.dest in @@ -528,22 +522,22 @@ let eval_assumed_function_call_concrete (config : C.config) * 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 = + let cf_eval_call cf (args_vl : typed_value list) : m_fun = fun ctx -> (* 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 = E.VarId.zero in + let ret_vid = VarId.zero in let ret_ty = get_assumed_function_return_type ctx fid generics 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 = - E.VarId.mapi_from1 - (fun id (v : V.typed_value) -> (mk_var id None v.V.ty, v)) + VarId.mapi_from1 + (fun id (v : typed_value) -> (mk_var id None v.ty, v)) args_vl in let cc = comp cc (push_vars input_vars) in @@ -557,8 +551,7 @@ let eval_assumed_function_call_concrete (config : C.config) | BoxFree -> (* Should have been treated above *) raise (Failure "Unreachable") | ArrayIndexShared | ArrayIndexMut | ArrayToSliceShared - | ArrayToSliceMut | ArrayRepeat | SliceIndexShared | SliceIndexMut - | SliceLen -> + | ArrayToSliceMut | ArrayRepeat | SliceIndexShared | SliceIndexMut -> raise (Failure "Unimplemented") in @@ -582,49 +575,48 @@ let eval_assumed_function_call_concrete (config : C.config) which can end or not. *) let create_empty_abstractions_from_abs_region_groups - (kind : T.RegionGroupId.id -> V.abs_kind) (rgl : A.abs_region_group list) - (region_can_end : T.RegionGroupId.id -> bool) : V.abs list = + (kind : RegionGroupId.id -> abs_kind) (rgl : abs_region_group list) + (region_can_end : RegionGroupId.id -> bool) : 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 + let abs_to_ancestors_regions : RegionId.Set.t AbstractionId.Map.t ref = + ref AbstractionId.Map.empty in (* Auxiliary function to create one abstraction *) - let create_abs (rg_id : T.RegionGroupId.id) (rg : A.abs_region_group) : V.abs - = - let abs_id = rg.T.id in + let create_abs (rg_id : RegionGroupId.id) (rg : abs_region_group) : abs = + let abs_id = rg.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 + (fun s pid -> AbstractionId.Set.add pid s) + 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 + (fun s rid -> RegionId.Set.add rid s) + 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 + RegionId.Set.union acc + (AbstractionId.Map.find parent_id !abs_to_ancestors_regions)) + RegionId.Set.empty rg.parents in let ancestors_regions_union_current_regions = - T.RegionId.Set.union ancestors_regions regions + RegionId.Set.union ancestors_regions regions in let can_end = region_can_end rg_id in abs_to_ancestors_regions := - V.AbstractionId.Map.add abs_id ancestors_regions_union_current_regions + AbstractionId.Map.add abs_id ancestors_regions_union_current_regions !abs_to_ancestors_regions; (* Create the abstraction *) { - V.abs_id; + abs_id; kind = kind rg_id; can_end; parents; @@ -635,14 +627,13 @@ let create_empty_abstractions_from_abs_region_groups } in (* Apply *) - T.RegionGroupId.mapi create_abs rgl + RegionGroupId.mapi create_abs rgl let create_push_abstractions_from_abs_region_groups - (kind : T.RegionGroupId.id -> 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 = + (kind : RegionGroupId.id -> abs_kind) (rgl : abs_region_group list) + (region_can_end : RegionGroupId.id -> bool) + (compute_abs_avalues : abs -> eval_ctx -> eval_ctx * typed_avalue list) + (ctx : eval_ctx) : eval_ctx = (* Initialize the abstractions as empty (i.e., with no avalues) abstractions *) let empty_absl = create_empty_abstractions_from_abs_region_groups kind rgl region_can_end @@ -650,7 +641,7 @@ let create_push_abstractions_from_abs_region_groups (* 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 = + let insert_abs (ctx : eval_ctx) (abs : abs) : 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 *) @@ -663,7 +654,7 @@ let create_push_abstractions_from_abs_region_groups List.fold_left insert_abs ctx empty_absl (** Evaluate a statement *) -let rec eval_statement (config : C.config) (st : A.statement) : st_cm_fun = +let rec eval_statement (config : config) (st : statement) : st_cm_fun = fun cf ctx -> (* Debugging *) log#ldebug @@ -676,23 +667,23 @@ let rec eval_statement (config : C.config) (st : A.statement) : st_cm_fun = * checking the invariants *) let cc = greedy_expand_symbolic_values config in (* Sanity check *) - let cc = comp cc Inv.cf_check_invariants in + let cc = comp cc Invariants.cf_check_invariants in (* Evaluate *) let cf_eval_st cf : m_fun = fun ctx -> match st.content with - | A.Assign (p, rvalue) -> ( + | Assign (p, rvalue) -> ( (* We handle global assignments separately *) match rvalue with - | E.Global gid -> + | Global gid -> (* Evaluate the global *) eval_global config p gid cf ctx | _ -> (* Evaluate the rvalue *) let cf_eval_rvalue = eval_rvalue_not_global config rvalue in (* Assign *) - let cf_assign cf (res : (V.typed_value, eval_error) result) ctx = + let cf_assign cf (res : (typed_value, eval_error) result) ctx = log#ldebug (lazy ("about to assign to place: " ^ place_to_string ctx p @@ -706,11 +697,10 @@ let rec eval_statement (config : C.config) (st : A.statement) : st_cm_fun = * also it can lead to issues - for instance, if we borrow a * reserved borrow, we later can't translate it to pure values...) *) match rvalue with - | E.Global _ -> raise (Failure "Unreachable") - | E.Use _ - | E.RvRef (_, (E.Shared | E.Mut | E.TwoPhaseMut | E.Shallow)) - | E.UnaryOp _ | E.BinaryOp _ | E.Discriminant _ - | E.Aggregate _ -> + | Global _ -> raise (Failure "Unreachable") + | Use _ + | RvRef (_, (BShared | BMut | BTwoPhaseMut | BShallow)) + | UnaryOp _ | BinaryOp _ | Discriminant _ | Aggregate _ -> let rp = rvalue_get_place rvalue in let rp = match rp with @@ -723,18 +713,18 @@ let rec eval_statement (config : C.config) (st : A.statement) : st_cm_fun = (* Compose and apply *) comp cf_eval_rvalue cf_assign cf ctx) - | A.FakeRead p -> eval_fake_read config p (cf Unit) ctx - | A.SetDiscriminant (p, variant_id) -> + | FakeRead p -> eval_fake_read config p (cf Unit) ctx + | 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) -> + | Drop p -> drop_value config p (cf Unit) ctx + | Assert assertion -> eval_assertion config assertion cf ctx + | Call call -> eval_function_call config call cf ctx + | Panic -> cf Panic ctx + | Return -> cf Return ctx + | Break i -> cf (Break i) ctx + | Continue i -> cf (Continue i) ctx + | Nop -> cf Unit ctx + | Sequence (st1, st2) -> (* Evaluate the first statement *) let cf_st1 = eval_statement config st1 in (* Evaluate the sequence *) @@ -749,37 +739,36 @@ let rec eval_statement (config : C.config) (st : A.statement) : st_cm_fun = in (* Compose and apply *) comp cf_st1 cf_st2 cf ctx - | A.Loop loop_body -> + | Loop loop_body -> InterpreterLoops.eval_loop config (eval_statement config loop_body) cf ctx - | A.Switch switch -> eval_switch config switch cf ctx + | Switch switch -> eval_switch config switch cf ctx in (* Compose and apply *) comp cc cf_eval_st cf ctx -and eval_global (config : C.config) (dest : E.place) (gid : LA.GlobalDeclId.id) - : st_cm_fun = +and eval_global (config : config) (dest : place) (gid : GlobalDeclId.id) : + st_cm_fun = fun cf ctx -> - let global = C.ctx_lookup_global_decl ctx gid in + let global = ctx_lookup_global_decl ctx gid in match config.mode with | ConcreteMode -> (* Treat the evaluation of the global as a call to the global body (without arguments) *) let func = { - E.func = FunId (FRegular global.body_id); - generics = TypesUtils.mk_empty_generic_args; + func = FunId (FRegular global.body); + generics = TypesUtils.empty_generic_args; trait_and_method_generic_args = None; } in - let call = { A.func; args = []; dest } in - (eval_transparent_function_call_concrete config global.body_id call) - cf ctx + let call = { func; args = []; dest } in + (eval_transparent_function_call_concrete config global.body call) 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}). *) assert (ty_no_regions global.ty); - let sval = mk_fresh_symbolic_value V.Global global.ty in + let sval = mk_fresh_symbolic_value Global global.ty in let cc = assign_to_place config (mk_typed_value_from_symbolic_value sval) dest in @@ -787,7 +776,7 @@ and eval_global (config : C.config) (dest : E.place) (gid : LA.GlobalDeclId.id) S.synthesize_global_eval gid sval e (** Evaluate a switch *) -and eval_switch (config : C.config) (switch : A.switch) : st_cm_fun = +and eval_switch (config : config) (switch : switch) : 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 @@ -801,14 +790,14 @@ and eval_switch (config : C.config) (switch : A.switch) : st_cm_fun = let cf_match : st_cm_fun = fun cf ctx -> match switch with - | A.If (op, st1, st2) -> + | If (op, st1, st2) -> (* Evaluate the operand *) let cf_eval_op = eval_operand config op in (* Switch on the value *) - let cf_if (cf : st_m_fun) (op_v : V.typed_value) : m_fun = + let cf_if (cf : st_m_fun) (op_v : typed_value) : m_fun = fun ctx -> match op_v.value with - | V.VLiteral (PV.VBool b) -> + | VLiteral (VBool b) -> (* Evaluate the if and the branch body *) let cf_branch cf : m_fun = (* Branch *) @@ -829,18 +818,18 @@ and eval_switch (config : C.config) (switch : A.switch) : st_cm_fun = in (* Compose *) comp cf_eval_op cf_if cf ctx - | A.SwitchInt (op, int_ty, stgts, otherwise) -> + | SwitchInt (op, int_ty, stgts, otherwise) -> (* Evaluate the operand *) let cf_eval_op = eval_operand config op in (* Switch on the value *) - let cf_switch (cf : st_m_fun) (op_v : V.typed_value) : m_fun = + let cf_switch (cf : st_m_fun) (op_v : typed_value) : m_fun = fun ctx -> match op_v.value with - | V.VLiteral (PV.VScalar sv) -> + | VLiteral (VScalar sv) -> (* Evaluate the branch *) let cf_eval_branch cf = (* Sanity check *) - assert (sv.PV.int_ty = int_ty); + assert (sv.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 @@ -876,7 +865,7 @@ and eval_switch (config : C.config) (switch : A.switch) : st_cm_fun = in (* Compose *) comp cf_eval_op cf_switch cf ctx - | A.Match (p, stgts, otherwise) -> + | Match (p, stgts, otherwise) -> (* Access the place *) let access = Read in let expand_prim_copy = false in @@ -884,7 +873,7 @@ and eval_switch (config : C.config) (switch : A.switch) : st_cm_fun = access_rplace_reorganize_and_read config expand_prim_copy access p cf in (* Match on the value *) - let cf_match (cf : st_m_fun) (p_v : V.typed_value) : m_fun = + let cf_match (cf : st_m_fun) (p_v : typed_value) : m_fun = fun ctx -> (* The value may be shared: we need to ignore the shared loans to read the value itself *) @@ -915,18 +904,17 @@ and eval_switch (config : C.config) (switch : A.switch) : st_cm_fun = 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 = +and eval_function_call (config : config) (call : call) : st_cm_fun = (* There are several cases: - this is a local function, in which case we execute its body - this is an assumed function, in which case there is a special treatment - this is a trait method *) match config.mode with - | C.ConcreteMode -> eval_function_call_concrete config call - | C.SymbolicMode -> eval_function_call_symbolic config call + | ConcreteMode -> eval_function_call_concrete config call + | SymbolicMode -> eval_function_call_symbolic config call -and eval_function_call_concrete (config : C.config) (call : A.call) : st_cm_fun - = +and eval_function_call_concrete (config : config) (call : call) : st_cm_fun = fun cf ctx -> match call.func.func with | FunId (FRegular fid) -> @@ -939,25 +927,24 @@ and eval_function_call_concrete (config : C.config) (call : A.call) : st_cm_fun eval_assumed_function_call_concrete config fid call (cf Unit) ctx | TraitMethod _ -> raise (Failure "Unimplemented") -and eval_function_call_symbolic (config : C.config) (call : A.call) : st_cm_fun - = +and eval_function_call_symbolic (config : config) (call : call) : st_cm_fun = match call.func.func with | FunId (FRegular _) | TraitMethod _ -> eval_transparent_function_call_symbolic config call | FunId (FAssumed fid) -> eval_assumed_function_call_symbolic config fid call (** Evaluate a local (i.e., non-assumed) function call in concrete mode *) -and eval_transparent_function_call_concrete (config : C.config) - (fid : A.FunDeclId.id) (call : A.call) : st_cm_fun = +and eval_transparent_function_call_concrete (config : config) + (fid : FunDeclId.id) (call : call) : st_cm_fun = let generics = call.func.generics in - let args = call.A.args in - let dest = call.A.dest in + let args = call.args in + let dest = call.dest in (* Sanity check: we don't fully handle the const generic vars environment in concrete mode yet *) assert (generics.const_generics = []); fun cf ctx -> (* Retrieve the (correctly instantiated) body *) - let def = C.ctx_lookup_fun_decl ctx fid in + let def = 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 @@ -965,20 +952,20 @@ and eval_transparent_function_call_concrete (config : C.config) raise (Failure ("Can't evaluate a call to an opaque function: " - ^ Print.name_to_string def.name)) + ^ name_to_string ctx def.name)) | Some body -> body in (* TODO: we need to normalize the types if we want to correctly support traits *) assert (generics.trait_refs = []); (* There shouldn't be any reference to Self *) - let tr_self = T.UnknownTrait __FUNCTION__ in + let tr_self = UnknownTrait __FUNCTION__ in let subst = - Subst.make_subst_from_generics def.A.signature.generics generics tr_self + Subst.make_subst_from_generics def.signature.generics generics tr_self in let locals, body_st = Subst.fun_body_substitute_in_body subst body in (* Evaluate the input operands *) - assert (List.length args = body.A.arg_count); + assert (List.length args = body.arg_count); let cc = eval_operands config args in (* Push a frame delimiter - we use {!comp_transmit} to transmit the result @@ -994,7 +981,7 @@ and eval_transparent_function_call_concrete (config : C.config) | _ -> raise (Failure "Unreachable") in let input_locals, locals = - Collections.List.split_at locals body.A.arg_count + Collections.List.split_at locals body.arg_count in let cc = comp_transmit cc (push_var ret_var (mk_bottom ret_var.var_ty)) in @@ -1032,8 +1019,8 @@ and eval_transparent_function_call_concrete (config : C.config) cc cf ctx (** Evaluate a local (i.e., non-assumed) function call in symbolic mode *) -and eval_transparent_function_call_symbolic (config : C.config) (call : A.call) - : st_cm_fun = +and eval_transparent_function_call_symbolic (config : config) (call : call) : + st_cm_fun = fun cf ctx -> (* Instantiate the signature and introduce fresh abstractions and region ids while doing so. @@ -1105,21 +1092,21 @@ and eval_transparent_function_call_symbolic (config : C.config) (call : A.call) let func, generics, def, inst_sg = match call.func.func with | FunId (FRegular fid) -> - let def = C.ctx_lookup_fun_decl ctx fid in + let def = ctx_lookup_fun_decl ctx fid in log#ldebug (lazy ("fun call:\n- call: " ^ call_to_string ctx call ^ "\n- call.generics:\n" - ^ PA.generic_args_to_string ctx call.func.generics + ^ generic_args_to_string ctx call.func.generics ^ "\n- def.signature:\n" - ^ fun_sig_to_string ctx def.A.signature)); - let tr_self = T.UnknownTrait __FUNCTION__ in + ^ fun_sig_to_string ctx def.signature)); + let tr_self = UnknownTrait __FUNCTION__ in let regions_hierarchy = LlbcAstUtils.FunIdMap.find (FRegular fid) ctx.fun_context.regions_hierarchies in let inst_sg = - instantiate_fun_sig ctx call.func.generics tr_self def.A.signature + instantiate_fun_sig ctx call.func.generics tr_self def.signature regions_hierarchy in (call.func.func, call.func.generics, def, inst_sg) @@ -1131,9 +1118,9 @@ and eval_transparent_function_call_symbolic (config : C.config) (call : A.call) (lazy ("trait method call:\n- call: " ^ call_to_string ctx call ^ "\n- method name: " ^ method_name ^ "\n- call.generics:\n" - ^ PA.generic_args_to_string ctx call.func.generics + ^ generic_args_to_string ctx call.func.generics ^ "\n- trait and method generics:\n" - ^ PA.generic_args_to_string ctx + ^ generic_args_to_string ctx (Option.get call.func.trait_and_method_generic_args))); (* When instantiating, we need to group the generics for the trait ref and the method *) @@ -1144,7 +1131,7 @@ and eval_transparent_function_call_symbolic (config : C.config) (call : A.call) match trait_ref.trait_id with | TraitImpl impl_id -> ( (* Lookup the trait impl *) - let trait_impl = C.ctx_lookup_trait_impl ctx impl_id in + let trait_impl = ctx_lookup_trait_impl ctx impl_id in log#ldebug (lazy ("trait impl: " ^ trait_impl_to_string ctx trait_impl)); (* First look in the required methods *) @@ -1156,17 +1143,17 @@ and eval_transparent_function_call_symbolic (config : C.config) (call : A.call) match method_id with | Some (_, id) -> (* This is a required method *) - let method_def = C.ctx_lookup_fun_decl ctx id in + let method_def = ctx_lookup_fun_decl ctx id in (* Instantiate *) - let tr_self = T.TraitRef trait_ref in - let fid : A.fun_id = FRegular id in + let tr_self = TraitRef trait_ref in + let fid : fun_id = FRegular id in let regions_hierarchy = LlbcAstUtils.FunIdMap.find fid ctx.fun_context.regions_hierarchies in let inst_sg = - instantiate_fun_sig ctx generics tr_self - method_def.A.signature regions_hierarchy + instantiate_fun_sig ctx generics tr_self method_def.signature + regions_hierarchy in (* Also update the function identifier: we want to forget the fact that we called a trait method, and treat it as @@ -1174,14 +1161,14 @@ and eval_transparent_function_call_symbolic (config : C.config) (call : A.call) which implements the method. In order to do this properly, we also need to update the generics. *) - let func = E.FunId fid in + let func = FunId fid in (func, generics, method_def, inst_sg) | None -> (* If not found, lookup the methods provided by the trait *declaration* (remember: for now, we forbid overriding provided methods) *) assert (trait_impl.provided_methods = []); let trait_decl = - C.ctx_lookup_trait_decl ctx + ctx_lookup_trait_decl ctx trait_ref.trait_decl_ref.trait_decl_id in let _, method_id = @@ -1190,7 +1177,7 @@ and eval_transparent_function_call_symbolic (config : C.config) (call : A.call) trait_decl.provided_methods in let method_id = Option.get method_id in - let method_def = C.ctx_lookup_fun_decl ctx method_id in + let method_def = ctx_lookup_fun_decl ctx method_id in (* For the instantiation we have to do something peculiar because the method was defined for the trait declaration. We have to group: @@ -1216,24 +1203,24 @@ and eval_transparent_function_call_symbolic (config : C.config) (call : A.call) (lazy ("provided method call:" ^ "\n- method name: " ^ method_name ^ "\n- all_generics:\n" - ^ PA.generic_args_to_string ctx all_generics + ^ generic_args_to_string ctx all_generics ^ "\n- parent params info: " - ^ Print.option_to_string A.show_params_info + ^ Print.option_to_string show_params_info method_def.signature.parent_params_info)); let regions_hierarchy = LlbcAstUtils.FunIdMap.find (FRegular method_id) ctx.fun_context.regions_hierarchies in - let tr_self = T.TraitRef trait_ref in + let tr_self = TraitRef trait_ref in let inst_sg = instantiate_fun_sig ctx all_generics tr_self - method_def.A.signature regions_hierarchy + method_def.signature regions_hierarchy in (call.func.func, call.func.generics, method_def, inst_sg)) | _ -> (* We are using a local clause - we lookup the trait decl *) let trait_decl = - C.ctx_lookup_trait_decl ctx trait_ref.trait_decl_ref.trait_decl_id + ctx_lookup_trait_decl ctx trait_ref.trait_decl_ref.trait_decl_id in (* Lookup the method decl in the required *and* the provided methods *) let _, method_id = @@ -1247,22 +1234,22 @@ and eval_transparent_function_call_symbolic (config : C.config) (call : A.call) (fun (s, _) -> s = method_name) (List.append trait_decl.required_methods provided) in - let method_def = C.ctx_lookup_fun_decl ctx method_id in + let method_def = ctx_lookup_fun_decl ctx method_id in log#ldebug (lazy ("method:\n" ^ fun_decl_to_string ctx method_def)); (* Instantiate *) let regions_hierarchy = LlbcAstUtils.FunIdMap.find (FRegular method_id) ctx.fun_context.regions_hierarchies in - let tr_self = T.TraitRef trait_ref in + let tr_self = TraitRef trait_ref in let inst_sg = - instantiate_fun_sig ctx generics tr_self method_def.A.signature + instantiate_fun_sig ctx generics tr_self method_def.signature regions_hierarchy in (call.func.func, call.func.generics, method_def, inst_sg)) in (* Sanity check *) - assert (List.length call.args = List.length def.A.signature.inputs); + assert (List.length call.args = List.length def.signature.inputs); (* Evaluate the function call *) eval_function_call_symbolic_from_inst_sig config func inst_sg generics call.args call.dest cf ctx @@ -1278,10 +1265,9 @@ and eval_transparent_function_call_symbolic (config : C.config) (call : A.call) overriding them. We treat them as regular method, which take an additional trait ref as input. *) -and eval_function_call_symbolic_from_inst_sig (config : C.config) - (fid : A.fun_id_or_trait_method_ref) (inst_sg : A.inst_fun_sig) - (generics : T.generic_args) (args : E.operand list) (dest : E.place) : - st_cm_fun = +and eval_function_call_symbolic_from_inst_sig (config : config) + (fid : fun_id_or_trait_method_ref) (inst_sg : inst_fun_sig) + (generics : generic_args) (args : operand list) (dest : place) : st_cm_fun = fun cf ctx -> log#ldebug (lazy @@ -1290,14 +1276,14 @@ and eval_function_call_symbolic_from_inst_sig (config : C.config) ^ "\n- inst_sg:\n" ^ inst_fun_sig_to_string ctx inst_sg ^ "\n- call.generics:\n" - ^ PA.generic_args_to_string ctx generics + ^ generic_args_to_string ctx generics ^ "\n- args:\n" ^ String.concat ", " (List.map (operand_to_string ctx) args) ^ "\n- dest:\n" ^ place_to_string ctx dest)); (* 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_sv_ty = inst_sg.output in + let ret_spc = mk_fresh_symbolic_value 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 @@ -1309,16 +1295,16 @@ and eval_function_call_symbolic_from_inst_sig (config : C.config) 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 = + let abs_ids = List.map (fun rg -> rg.id) inst_sg.regions_hierarchy in + let cf_call cf (args : typed_value list) : m_fun = fun ctx -> - let args_with_rtypes = List.combine args inst_sg.A.inputs in + let args_with_rtypes = List.combine args inst_sg.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) + (fun ((arg, rty) : typed_value * rty) -> + arg.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 @@ -1334,8 +1320,8 @@ and eval_function_call_symbolic_from_inst_sig (config : C.config) * 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 = + let compute_abs_avalues (abs : abs) (ctx : eval_ctx) : + eval_ctx * typed_avalue list = (* Project over the input values *) let ctx, args_projs = List.fold_left_map @@ -1348,12 +1334,12 @@ and eval_function_call_symbolic_from_inst_sig (config : C.config) (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 call_id = fresh_fun_call_id () in let region_can_end _ = true in let ctx = create_push_abstractions_from_abs_region_groups - (fun rg_id -> V.FunCall (call_id, rg_id)) - inst_sg.A.regions_hierarchy region_can_end compute_abs_avalues ctx + (fun rg_id -> FunCall (call_id, rg_id)) + inst_sg.regions_hierarchy region_can_end compute_abs_avalues ctx in (* Apply the continuation *) @@ -1381,9 +1367,9 @@ and eval_function_call_symbolic_from_inst_sig (config : C.config) List.partition (fun abs_id -> (* Lookup the abstraction *) - let abs = C.ctx_lookup_abs ctx abs_id in + let abs = ctx_lookup_abs ctx abs_id in (* Check if it has parents *) - V.AbstractionId.Set.is_empty abs.parents + AbstractionId.Set.is_empty abs.parents (* Check if it contains non-ignored loans *) && Option.is_none (InterpreterBorrowsCore @@ -1395,7 +1381,7 @@ and eval_function_call_symbolic_from_inst_sig (config : C.config) (* 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 no_loans_abs = 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 @@ -1422,8 +1408,8 @@ and eval_function_call_symbolic_from_inst_sig (config : C.config) cc (cf Unit) ctx (** Evaluate a non-local function call in symbolic mode *) -and eval_assumed_function_call_symbolic (config : C.config) - (fid : A.assumed_fun_id) (call : A.call) : st_cm_fun = +and eval_assumed_function_call_symbolic (config : config) (fid : assumed_fun_id) + (call : call) : st_cm_fun = fun cf ctx -> let generics = call.func.generics in let args = call.args in @@ -1461,7 +1447,7 @@ and eval_assumed_function_call_symbolic (config : C.config) ctx.fun_context.regions_hierarchies in (* There shouldn't be any reference to Self *) - let tr_self = T.UnknownTrait __FUNCTION__ in + let tr_self = UnknownTrait __FUNCTION__ in instantiate_fun_sig ctx generics tr_self (Assumed.get_assumed_fun_sig fid) regions_hierarchy @@ -1472,7 +1458,7 @@ and eval_assumed_function_call_symbolic (config : C.config) inst_sig generics args dest cf ctx (** Evaluate a statement seen as a function body *) -and eval_function_body (config : C.config) (body : A.statement) : st_cm_fun = +and eval_function_body (config : config) (body : statement) : st_cm_fun = fun cf ctx -> let cc = eval_statement config body in let cf_finish cf res = @@ -1482,7 +1468,7 @@ and eval_function_body (config : C.config) (body : A.statement) : st_cm_fun = * checking the invariants *) let cc = greedy_expand_symbolic_values config in (* Sanity check *) - let cc = comp_check_ctx cc Inv.check_invariants in + let cc = comp_check_ctx cc Invariants.check_invariants in (* Continue *) cc (cf res) in diff --git a/compiler/InterpreterStatements.mli b/compiler/InterpreterStatements.mli index e65758ae..d84e8be6 100644 --- a/compiler/InterpreterStatements.mli +++ b/compiler/InterpreterStatements.mli @@ -1,15 +1,8 @@ -module T = Types -module PV = PrimitiveValues -module V = Values -module E = Expressions -module C = Contexts -module Subst = Substitute -module A = LlbcAst -module L = Logging -module Inv = Invariants -module S = SynthesizeSymbolic +open Types +open Values +open Contexts +open LlbcAst open Cps -open InterpreterExpressions (** Pop the current frame. @@ -17,13 +10,13 @@ open InterpreterExpressions dummy variables, after ending the proper borrows of course) but the return variable, move the return value out of the return variable, remove all the local variables (but preserve the abstractions!), remove the - {!constructor:C.env_elem.Frame} indicator delimiting the current frame and + {!constructor:env_elem.Frame} indicator delimiting the current frame and handle the return value to the continuation. If the boolean is false, we don't move the return value, and call the continuation with [None]. *) -val pop_frame : C.config -> bool -> (V.typed_value option -> m_fun) -> m_fun +val pop_frame : config -> bool -> (typed_value option -> m_fun) -> m_fun (** Helper. @@ -44,15 +37,15 @@ val pop_frame : C.config -> bool -> (V.typed_value option -> m_fun) -> m_fun - [ctx] *) val create_push_abstractions_from_abs_region_groups : - (T.RegionGroupId.id -> V.abs_kind) -> - LA.abs_region_group list -> - (T.RegionGroupId.id -> bool) -> - (V.abs -> C.eval_ctx -> C.eval_ctx * V.typed_avalue list) -> - C.eval_ctx -> - C.eval_ctx + (RegionGroupId.id -> abs_kind) -> + abs_region_group list -> + (RegionGroupId.id -> bool) -> + (abs -> eval_ctx -> eval_ctx * typed_avalue list) -> + eval_ctx -> + eval_ctx (** Evaluate a statement *) -val eval_statement : C.config -> LA.statement -> st_cm_fun +val eval_statement : config -> statement -> st_cm_fun (** Evaluate a statement seen as a function body *) -val eval_function_body : C.config -> LA.statement -> st_cm_fun +val eval_function_body : config -> statement -> st_cm_fun diff --git a/compiler/InterpreterUtils.ml b/compiler/InterpreterUtils.ml index e5a5b2ea..ecd8f53f 100644 --- a/compiler/InterpreterUtils.ml +++ b/compiler/InterpreterUtils.ml @@ -1,25 +1,22 @@ -module T = Types -module V = Values -module E = Expressions -module C = Contexts -module Subst = Substitute -module A = LlbcAst -module L = Logging +open Types +open Values +open Expressions +open Contexts +open LlbcAst open Utils open TypesUtils -module PA = Print.EvalCtxLlbcAst open Cps (* TODO: we should probably rename the file to ContextsUtils *) (** The local logger *) -let log = L.interpreter_log +let log = Logging.interpreter_log (** Some utilities *) (** Auxiliary function - call a function which requires a continuation, and return the let context given to the continuation *) -let get_cf_ctx_no_synth (f : cm_fun) (ctx : C.eval_ctx) : C.eval_ctx = +let get_cf_ctx_no_synth (f : cm_fun) (ctx : eval_ctx) : eval_ctx = let nctx = ref None in let cf ctx = assert (!nctx = None); @@ -31,120 +28,120 @@ let get_cf_ctx_no_synth (f : cm_fun) (ctx : C.eval_ctx) : C.eval_ctx = let eval_ctx_to_string_no_filter = Print.Contexts.eval_ctx_to_string_no_filter let eval_ctx_to_string = Print.Contexts.eval_ctx_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 fun_sig_to_string = PA.fun_sig_to_string -let inst_fun_sig_to_string = PA.inst_fun_sig_to_string +let name_to_string = Print.EvalCtx.name_to_string +let symbolic_value_to_string = Print.EvalCtx.symbolic_value_to_string +let borrow_content_to_string = Print.EvalCtx.borrow_content_to_string +let loan_content_to_string = Print.EvalCtx.loan_content_to_string +let aborrow_content_to_string = Print.EvalCtx.aborrow_content_to_string +let aloan_content_to_string = Print.EvalCtx.aloan_content_to_string +let aproj_to_string = Print.EvalCtx.aproj_to_string +let typed_value_to_string = Print.EvalCtx.typed_value_to_string +let typed_avalue_to_string = Print.EvalCtx.typed_avalue_to_string +let place_to_string = Print.EvalCtx.place_to_string +let operand_to_string = Print.EvalCtx.operand_to_string +let fun_sig_to_string = Print.EvalCtx.fun_sig_to_string +let inst_fun_sig_to_string = Print.EvalCtx.inst_fun_sig_to_string +let ty_to_string = Print.EvalCtx.ty_to_string +let generic_args_to_string = Print.EvalCtx.generic_args_to_string let fun_id_or_trait_method_ref_to_string = - PA.fun_id_or_trait_method_ref_to_string + Print.EvalCtx.fun_id_or_trait_method_ref_to_string -let fun_decl_to_string = PA.fun_decl_to_string -let call_to_string = PA.call_to_string +let fun_decl_to_string = Print.EvalCtx.fun_decl_to_string +let call_to_string = Print.EvalCtx.call_to_string let trait_impl_to_string ctx = - PA.trait_impl_to_string { ctx with type_vars = []; const_generic_vars = [] } + Print.EvalCtx.trait_impl_to_string + { ctx with type_vars = []; const_generic_vars = [] } -let statement_to_string ctx = PA.statement_to_string ctx "" " " -let statement_to_string_with_tab ctx = PA.statement_to_string ctx " " " " -let env_elem_to_string ctx = PA.env_elem_to_string ctx "" " " +let statement_to_string ctx = Print.EvalCtx.statement_to_string ctx "" " " + +let statement_to_string_with_tab ctx = + Print.EvalCtx.statement_to_string ctx " " " " + +let env_elem_to_string ctx = Print.EvalCtx.env_elem_to_string ctx "" " " let env_to_string ctx env = eval_ctx_to_string { ctx with env } -let abs_to_string ctx = PA.abs_to_string ctx "" " " +let abs_to_string ctx = Print.EvalCtx.abs_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 same_symbolic_id (sv0 : symbolic_value) (sv1 : symbolic_value) : bool = + sv0.sv_id = sv1.sv_id -let mk_var (index : E.VarId.id) (name : string option) (var_ty : T.ty) : A.var = - { A.index; name; var_ty } +let mk_var (index : VarId.id) (name : string option) (var_ty : ty) : var = + { index; name; var_ty } (** Small helper - TODO: move *) -let mk_place_from_var_id (var_id : E.VarId.id) : E.place = +let mk_place_from_var_id (var_id : VarId.id) : place = { var_id; projection = [] } (** Create a fresh symbolic value *) -let mk_fresh_symbolic_value (sv_kind : V.sv_kind) (ty : T.ty) : V.symbolic_value - = +let mk_fresh_symbolic_value (sv_kind : sv_kind) (ty : ty) : symbolic_value = (* Sanity check *) assert (ty_is_rty ty); - let sv_id = C.fresh_symbolic_value_id () in - let svalue = { V.sv_kind; V.sv_id; V.sv_ty = ty } in + let sv_id = fresh_symbolic_value_id () in + let svalue = { sv_kind; sv_id; sv_ty = ty } in svalue -let mk_fresh_symbolic_value_from_no_regions_ty (sv_kind : V.sv_kind) (ty : T.ty) - : V.symbolic_value = +let mk_fresh_symbolic_value_from_no_regions_ty (sv_kind : sv_kind) (ty : ty) : + symbolic_value = assert (ty_no_regions ty); mk_fresh_symbolic_value sv_kind ty (** Create a fresh symbolic value *) -let mk_fresh_symbolic_typed_value (sv_kind : V.sv_kind) (rty : T.ty) : - V.typed_value = +let mk_fresh_symbolic_typed_value (sv_kind : sv_kind) (rty : ty) : typed_value = assert (ty_is_rty rty); - let ty = Subst.erase_regions rty in + let ty = Substitute.erase_regions rty in (* Generate the fresh a symbolic value *) let value = mk_fresh_symbolic_value sv_kind rty in - let value = V.VSymbolic value in - { V.value; V.ty } + let value = VSymbolic value in + { value; ty } -let mk_fresh_symbolic_typed_value_from_no_regions_ty (sv_kind : V.sv_kind) - (ty : T.ty) : V.typed_value = +let mk_fresh_symbolic_typed_value_from_no_regions_ty (sv_kind : sv_kind) + (ty : ty) : typed_value = assert (ty_no_regions ty); mk_fresh_symbolic_typed_value sv_kind 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.VSymbolic svalue in - let av : V.typed_value = - { V.value = av; V.ty = Subst.erase_regions svalue.V.sv_ty } +let mk_typed_value_from_symbolic_value (svalue : symbolic_value) : typed_value = + let av = VSymbolic svalue in + let av : typed_value = + { value = av; ty = Substitute.erase_regions svalue.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} ([_]). + returns {!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 = +let mk_aproj_loans_value_from_symbolic_value (regions : RegionId.Set.t) + (svalue : symbolic_value) : 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 + let av = ASymbolic (AProjLoans (svalue, [])) in + let av : typed_avalue = { value = av; ty = svalue.sv_ty } in av - else { V.value = V.AIgnored; ty = svalue.V.sv_ty } + else { value = AIgnored; ty = svalue.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.ty) : V.aproj = +let mk_aproj_borrows_from_symbolic_value (proj_regions : RegionId.Set.t) + (svalue : symbolic_value) (proj_ty : ty) : aproj = assert (ty_is_rty proj_ty); if ty_has_regions_in_set proj_regions proj_ty then - V.AProjBorrows (svalue, proj_ty) - else V.AIgnoredProjBorrows + AProjBorrows (svalue, proj_ty) + else 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 +let borrow_is_asb (bid : BorrowId.id) (asb : abstract_shared_borrow) : bool = + match asb with AsbBorrow bid' -> bid' = bid | AsbProjReborrows _ -> false (** TODO: move *) -let borrow_in_asb (bid : V.BorrowId.id) (asb : V.abstract_shared_borrows) : bool - = +let borrow_in_asb (bid : BorrowId.id) (asb : 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 remove_borrow_from_asb (bid : BorrowId.id) (asb : abstract_shared_borrows) : + abstract_shared_borrows = let removed = ref 0 in let asb = List.filter @@ -168,26 +165,26 @@ type ('a, 'b) concrete_or_abs = Concrete of 'a | Abstract of 'b [@@deriving show] (** Generic loan content: concrete or abstract *) -type g_loan_content = (V.loan_content, V.aloan_content) concrete_or_abs +type g_loan_content = (loan_content, aloan_content) concrete_or_abs [@@deriving show] (** Generic borrow content: concrete or abstract *) -type g_borrow_content = (V.borrow_content, V.aborrow_content) concrete_or_abs +type g_borrow_content = (borrow_content, aborrow_content) concrete_or_abs [@@deriving show] type abs_or_var_id = - | AbsId of V.AbstractionId.id - | VarId of E.VarId.id - | DummyVarId of C.DummyVarId.id + | AbsId of AbstractionId.id + | VarId of VarId.id + | DummyVarId of DummyVarId.id (** Utility exception *) -exception FoundBorrowContent of V.borrow_content +exception FoundBorrowContent of borrow_content (** Utility exception *) -exception FoundLoanContent of V.loan_content +exception FoundLoanContent of loan_content (** Utility exception *) -exception FoundABorrowContent of V.aborrow_content +exception FoundABorrowContent of aborrow_content (** Utility exception *) exception FoundGBorrowContent of g_borrow_content @@ -196,30 +193,30 @@ exception FoundGBorrowContent of g_borrow_content exception FoundGLoanContent of g_loan_content (** Utility exception *) -exception FoundAProjBorrows of V.symbolic_value * T.ty +exception FoundAProjBorrows of symbolic_value * ty -let symbolic_value_id_in_ctx (sv_id : V.SymbolicValueId.id) (ctx : C.eval_ctx) : +let symbolic_value_id_in_ctx (sv_id : SymbolicValueId.id) (ctx : eval_ctx) : bool = let obj = object - inherit [_] C.iter_eval_ctx as super + inherit [_] iter_eval_ctx as super method! visit_VSymbolic _ sv = - if sv.V.sv_id = sv_id then raise Found else () + if sv.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 () + if sv.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 = + let visit (asb : abstract_shared_borrow) : unit = match asb with - | V.AsbBorrow _ -> () - | V.AsbProjReborrows (sv, _) -> - if sv.V.sv_id = sv_id then raise Found else () + | AsbBorrow _ -> () + | AsbProjReborrows (sv, _) -> + if sv.sv_id = sv_id then raise Found else () in List.iter visit asb end @@ -236,21 +233,20 @@ let symbolic_value_id_in_ctx (sv_id : V.SymbolicValueId.id) (ctx : C.eval_ctx) : 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 = ty_regions s.V.sv_ty in - not (T.RegionId.Set.disjoint regions ended_regions) +let symbolic_value_has_ended_regions (ended_regions : RegionId.Set.t) + (s : symbolic_value) : bool = + let regions = ty_regions s.sv_ty in + not (RegionId.Set.disjoint regions ended_regions) -(** Check if a {!type:V.value} contains [⊥]. +(** Check if a {!type: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 bottom_in_value (ended_regions : RegionId.Set.t) (v : typed_value) : bool = let obj = object - inherit [_] V.iter_typed_value + inherit [_] iter_typed_value method! visit_VBottom _ = raise Found method! visit_symbolic_value _ s = @@ -264,21 +260,21 @@ let bottom_in_value (ended_regions : T.RegionId.Set.t) (v : V.typed_value) : false with Found -> true -let value_has_ret_symbolic_value_with_borrow_under_mut (ctx : C.eval_ctx) - (v : V.typed_value) : bool = +let value_has_ret_symbolic_value_with_borrow_under_mut (ctx : eval_ctx) + (v : typed_value) : bool = let obj = object - inherit [_] V.iter_typed_value + inherit [_] iter_typed_value method! visit_symbolic_value _ s = match s.sv_kind with - | V.FunCallRet | V.LoopOutput | V.LoopJoin -> + | FunCallRet | LoopOutput | LoopJoin -> 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 | V.LoopGivenBack | V.Aggregate - | V.ConstGeneric | V.TraitConst -> + | SynthInput | SynthInputGivenBack | FunCallGivenBack + | SynthRetGivenBack | Global | LoopGivenBack | Aggregate | ConstGeneric + | TraitConst -> () end in @@ -291,7 +287,7 @@ let value_has_ret_symbolic_value_with_borrow_under_mut (ctx : C.eval_ctx) (** 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 = +let rvalue_get_place (rv : rvalue) : place option = match rv with | Use (Copy p | Move p) -> Some p | Use (Constant _) -> None @@ -299,30 +295,29 @@ let rvalue_get_place (rv : E.rvalue) : E.place option = | UnaryOp _ | BinaryOp _ | Global _ | Discriminant _ | Aggregate _ -> None (** See {!ValuesUtils.symbolic_value_has_borrows} *) -let symbolic_value_has_borrows (ctx : C.eval_ctx) (sv : V.symbolic_value) : bool - = +let symbolic_value_has_borrows (ctx : eval_ctx) (sv : symbolic_value) : bool = ValuesUtils.symbolic_value_has_borrows ctx.type_context.type_infos sv (** See {!ValuesUtils.value_has_borrows}. *) -let value_has_borrows (ctx : C.eval_ctx) (v : V.value) : bool = +let value_has_borrows (ctx : eval_ctx) (v : value) : bool = ValuesUtils.value_has_borrows ctx.type_context.type_infos v (** See {!ValuesUtils.value_has_loans_or_borrows}. *) -let value_has_loans_or_borrows (ctx : C.eval_ctx) (v : V.value) : bool = +let value_has_loans_or_borrows (ctx : eval_ctx) (v : value) : bool = ValuesUtils.value_has_loans_or_borrows ctx.type_context.type_infos v (** See {!ValuesUtils.value_has_loans}. *) -let value_has_loans (v : V.value) : bool = ValuesUtils.value_has_loans v +let value_has_loans (v : value) : bool = ValuesUtils.value_has_loans v (** See {!compute_typed_value_ids}, {!compute_context_ids}, etc. *) type ids_sets = { - aids : V.AbstractionId.Set.t; - blids : V.BorrowId.Set.t; (** All the borrow/loan ids *) - borrow_ids : V.BorrowId.Set.t; (** Only the borrow ids *) - loan_ids : V.BorrowId.Set.t; (** Only the loan ids *) - dids : C.DummyVarId.Set.t; - rids : T.RegionId.Set.t; - sids : V.SymbolicValueId.Set.t; + aids : AbstractionId.Set.t; + blids : BorrowId.Set.t; (** All the borrow/loan ids *) + borrow_ids : BorrowId.Set.t; (** Only the borrow ids *) + loan_ids : BorrowId.Set.t; (** Only the loan ids *) + dids : DummyVarId.Set.t; + rids : RegionId.Set.t; + sids : SymbolicValueId.Set.t; } [@@deriving show] @@ -330,19 +325,17 @@ type ids_sets = { TODO: there misses information. *) -type ids_to_values = { - sids_to_values : V.symbolic_value V.SymbolicValueId.Map.t; -} +type ids_to_values = { sids_to_values : symbolic_value SymbolicValueId.Map.t } let compute_ids () = - let blids = ref V.BorrowId.Set.empty in - let borrow_ids = ref V.BorrowId.Set.empty in - let loan_ids = ref V.BorrowId.Set.empty in - let aids = ref V.AbstractionId.Set.empty in - let dids = ref C.DummyVarId.Set.empty in - let rids = ref T.RegionId.Set.empty in - let sids = ref V.SymbolicValueId.Set.empty in - let sids_to_values = ref V.SymbolicValueId.Map.empty in + let blids = ref BorrowId.Set.empty in + let borrow_ids = ref BorrowId.Set.empty in + let loan_ids = ref BorrowId.Set.empty in + let aids = ref AbstractionId.Set.empty in + let dids = ref DummyVarId.Set.empty in + let rids = ref RegionId.Set.empty in + let sids = ref SymbolicValueId.Set.empty in + let sids_to_values = ref SymbolicValueId.Map.empty in let get_ids () = { @@ -358,156 +351,154 @@ let compute_ids () = let get_ids_to_values () = { sids_to_values = !sids_to_values } in let obj = object - inherit [_] C.iter_eval_ctx as super - method! visit_dummy_var_id _ did = dids := C.DummyVarId.Set.add did !dids + inherit [_] iter_eval_ctx as super + method! visit_dummy_var_id _ did = dids := DummyVarId.Set.add did !dids method! visit_borrow_id _ id = - blids := V.BorrowId.Set.add id !blids; - borrow_ids := V.BorrowId.Set.add id !borrow_ids + blids := BorrowId.Set.add id !blids; + borrow_ids := BorrowId.Set.add id !borrow_ids method! visit_loan_id _ id = - blids := V.BorrowId.Set.add id !blids; - loan_ids := V.BorrowId.Set.add id !loan_ids + blids := BorrowId.Set.add id !blids; + loan_ids := BorrowId.Set.add id !loan_ids - method! visit_abstraction_id _ id = - aids := V.AbstractionId.Set.add id !aids - - method! visit_region_id _ id = rids := T.RegionId.Set.add id !rids + method! visit_abstraction_id _ id = aids := AbstractionId.Set.add id !aids + method! visit_region_id _ id = rids := RegionId.Set.add id !rids method! visit_symbolic_value env sv = - sids := V.SymbolicValueId.Set.add sv.sv_id !sids; - sids_to_values := V.SymbolicValueId.Map.add sv.sv_id sv !sids_to_values; + sids := SymbolicValueId.Set.add sv.sv_id !sids; + sids_to_values := SymbolicValueId.Map.add sv.sv_id sv !sids_to_values; super#visit_symbolic_value env sv method! visit_symbolic_value_id _ id = (* TODO: can we get there without going through [visit_symbolic_value] first? *) - sids := V.SymbolicValueId.Set.add id !sids + sids := SymbolicValueId.Set.add id !sids end in (obj, get_ids, get_ids_to_values) (** Compute the sets of ids found in a list of typed values. *) -let compute_typed_values_ids (xl : V.typed_value list) : - ids_sets * ids_to_values = +let compute_typed_values_ids (xl : typed_value list) : ids_sets * ids_to_values + = let compute, get_ids, get_ids_to_values = compute_ids () in List.iter (compute#visit_typed_value ()) xl; (get_ids (), get_ids_to_values ()) (** Compute the sets of ids found in a typed value. *) -let compute_typed_value_ids (x : V.typed_value) : ids_sets * ids_to_values = +let compute_typed_value_ids (x : typed_value) : ids_sets * ids_to_values = compute_typed_values_ids [ x ] (** Compute the sets of ids found in a list of abstractions. *) -let compute_absl_ids (xl : V.abs list) : ids_sets * ids_to_values = +let compute_absl_ids (xl : abs list) : ids_sets * ids_to_values = let compute, get_ids, get_ids_to_values = compute_ids () in List.iter (compute#visit_abs ()) xl; (get_ids (), get_ids_to_values ()) (** Compute the sets of ids found in an abstraction. *) -let compute_abs_ids (x : V.abs) : ids_sets * ids_to_values = +let compute_abs_ids (x : abs) : ids_sets * ids_to_values = compute_absl_ids [ x ] (** Compute the sets of ids found in an environment. *) -let compute_env_ids (x : C.env) : ids_sets * ids_to_values = +let compute_env_ids (x : env) : ids_sets * ids_to_values = let compute, get_ids, get_ids_to_values = compute_ids () in compute#visit_env () x; (get_ids (), get_ids_to_values ()) (** Compute the sets of ids found in an environment element. *) -let compute_env_elem_ids (x : C.env_elem) : ids_sets * ids_to_values = +let compute_env_elem_ids (x : env_elem) : ids_sets * ids_to_values = compute_env_ids [ x ] (** Compute the sets of ids found in a list of contexts. *) -let compute_contexts_ids (ctxl : C.eval_ctx list) : ids_sets * ids_to_values = +let compute_contexts_ids (ctxl : eval_ctx list) : ids_sets * ids_to_values = let compute, get_ids, get_ids_to_values = compute_ids () in List.iter (compute#visit_eval_ctx ()) ctxl; (get_ids (), get_ids_to_values ()) (** Compute the sets of ids found in a context. *) -let compute_context_ids (ctx : C.eval_ctx) : ids_sets * ids_to_values = +let compute_context_ids (ctx : eval_ctx) : ids_sets * ids_to_values = compute_contexts_ids [ ctx ] (** **WARNING**: this function doesn't compute the normalized types (for the trait type aliases). This should be computed afterwards. *) -let initialize_eval_context (ctx : C.decls_ctx) - (region_groups : T.RegionGroupId.id list) (type_vars : T.type_var list) - (const_generic_vars : T.const_generic_var list) : C.eval_ctx = - C.reset_global_counters (); +let initialize_eval_context (ctx : decls_ctx) + (region_groups : RegionGroupId.id list) (type_vars : type_var list) + (const_generic_vars : const_generic_var list) : eval_ctx = + reset_global_counters (); let const_generic_vars_map = - T.ConstGenericVarId.Map.of_list + ConstGenericVarId.Map.of_list (List.map - (fun (cg : T.const_generic_var) -> - let ty = T.TLiteral cg.ty in - let cv = mk_fresh_symbolic_typed_value V.ConstGeneric ty in + (fun (cg : const_generic_var) -> + let ty = TLiteral cg.ty in + let cv = mk_fresh_symbolic_typed_value ConstGeneric ty in (cg.index, cv)) const_generic_vars) in { - C.type_context = ctx.type_ctx; - C.fun_context = ctx.fun_ctx; - C.global_context = ctx.global_ctx; - C.trait_decls_context = ctx.trait_decls_ctx; - C.trait_impls_context = ctx.trait_impls_ctx; - C.region_groups; - C.type_vars; - C.const_generic_vars; - C.const_generic_vars_map; - C.norm_trait_types = C.TraitTypeRefMap.empty (* Empty for now *); - C.env = [ C.EFrame ]; - C.ended_regions = T.RegionId.Set.empty; + type_context = ctx.type_ctx; + fun_context = ctx.fun_ctx; + global_context = ctx.global_ctx; + trait_decls_context = ctx.trait_decls_ctx; + trait_impls_context = ctx.trait_impls_ctx; + region_groups; + type_vars; + const_generic_vars; + const_generic_vars_map; + norm_trait_types = TraitTypeRefMap.empty (* Empty for now *); + env = [ EFrame ]; + ended_regions = RegionId.Set.empty; } (** 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). *) -let instantiate_fun_sig (ctx : C.eval_ctx) (generics : T.generic_args) - (tr_self : T.trait_instance_id) (sg : A.fun_sig) - (regions_hierarchy : T.region_groups) : A.inst_fun_sig = +let instantiate_fun_sig (ctx : eval_ctx) (generics : generic_args) + (tr_self : trait_instance_id) (sg : fun_sig) + (regions_hierarchy : region_groups) : inst_fun_sig = log#ldebug (lazy ("instantiate_fun_sig:" ^ "\n- generics: " - ^ PA.generic_args_to_string ctx generics + ^ Print.EvalCtx.generic_args_to_string ctx generics ^ "\n- tr_self: " - ^ PA.trait_instance_id_to_string ctx tr_self + ^ Print.EvalCtx.trait_instance_id_to_string ctx tr_self ^ "\n- sg: " ^ fun_sig_to_string ctx sg)); (* Erase the regions in the generics we use for the instantiation *) - let generics = Subst.generic_args_erase_regions generics in - let tr_self = Subst.trait_instance_id_erase_regions tr_self in + let generics = Substitute.generic_args_erase_regions generics in + let tr_self = Substitute.trait_instance_id_erase_regions tr_self in (* 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)) + let abs_id = fresh_abstraction_id () in + (rg.id, abs_id)) regions_hierarchy in - let asubst_map : V.AbstractionId.id T.RegionGroupId.Map.t = + let asubst_map : AbstractionId.id 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 + (fun mp (rg_id, abs_id) -> RegionGroupId.Map.add rg_id abs_id mp) + 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 + let asubst (rg_id : RegionGroupId.id) : AbstractionId.id = + RegionGroupId.Map.find rg_id asubst_map in (* Generate fresh regions and their substitutions *) - let _, rsubst, _ = Subst.fresh_regions_with_substs sg.generics.regions in + let _, rsubst, _ = Substitute.fresh_regions_with_substs sg.generics.regions in (* Generate the type substitution Note that for now we don't support instantiating the type parameters with types containing regions. *) assert (List.for_all TypesUtils.ty_no_regions generics.types); assert (TypesUtils.trait_instance_id_no_regions tr_self); let tsubst = - Subst.make_type_subst_from_vars sg.generics.types generics.types + Substitute.make_type_subst_from_vars sg.generics.types generics.types in let cgsubst = - Subst.make_const_generic_subst_from_vars sg.generics.const_generics + Substitute.make_const_generic_subst_from_vars sg.generics.const_generics generics.const_generics in let tr_subst = - Subst.make_trait_subst_from_clauses sg.generics.trait_clauses + Substitute.make_trait_subst_from_clauses sg.generics.trait_clauses generics.trait_refs in (* Substitute the signature *) diff --git a/compiler/Invariants.ml b/compiler/Invariants.ml index 7830099f..49ba8370 100644 --- a/compiler/Invariants.ml +++ b/compiler/Invariants.ml @@ -1,29 +1,24 @@ (* The following module defines functions to check that some invariants * are always maintained by evaluation contexts *) -module T = Types -module PV = PrimitiveValues -module V = Values -module E = Expressions -module C = Contexts -module Subst = Substitute -module Assoc = AssociatedTypes -module A = LlbcAst -module L = Logging +open Types +open PrimitiveValues +open Values +open Contexts open Cps open TypesUtils open InterpreterUtils open InterpreterBorrowsCore (** The local logger *) -let log = L.invariants_log +let log = Logging.invariants_log type borrow_info = { - loan_kind : T.ref_kind; + loan_kind : 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; + loan_ids : BorrowId.Set.t; + borrow_ids : BorrowId.Set.t; } [@@deriving show] @@ -39,30 +34,26 @@ let set_outer_mut (info : outer_borrow_info) : outer_borrow_info = 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 ids_reprs_to_string (indent : string) (reprs : BorrowId.id BorrowId.Map.t) : + string = + BorrowId.Map.to_string (Some indent) 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 + (infos : borrow_info BorrowId.Map.t) : string = + BorrowId.Map.to_string (Some indent) show_borrow_info infos -type borrow_kind = Mut | Shared | Reserved +type borrow_kind = BMut | BShared | BReserved (** 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 = +let check_loans_borrows_relation_invariant (ctx : 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 + let ids_reprs : BorrowId.id BorrowId.Map.t ref = ref 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 borrows_infos : borrow_info BorrowId.Map.t ref = ref BorrowId.Map.empty in let context_to_string () : string = eval_ctx_to_string ctx ^ "- representants:\n" ^ ids_reprs_to_string " " !ids_reprs @@ -73,62 +64,61 @@ let check_loans_borrows_relation_invariant (ctx : C.eval_ctx) : unit = * 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 + let ignored_loans : (ref_kind * 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 = + let register_ignored_loan (rkind : ref_kind) (bid : 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 register_shared_loan (loan_in_abs : bool) (bids : 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)); + let repr_bid = BorrowId.Set.min_elt bids in + assert (not (BorrowId.Map.mem repr_bid infos)); (* Insert the mappings to the representant *) let reprs = - V.BorrowId.Set.fold + BorrowId.Set.fold (fun bid reprs -> - assert (not (V.BorrowId.Map.mem bid reprs)); - V.BorrowId.Map.add bid repr_bid reprs) + assert (not (BorrowId.Map.mem bid reprs)); + BorrowId.Map.add bid repr_bid reprs) bids reprs in (* Insert the loan info *) let info = { - loan_kind = T.Shared; + loan_kind = RShared; loan_in_abs; loan_ids = bids; - borrow_ids = V.BorrowId.Set.empty; + borrow_ids = BorrowId.Set.empty; } in - let infos = V.BorrowId.Map.add repr_bid info infos in + let infos = 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 register_mut_loan (loan_in_abs : bool) (bid : 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)); + assert (not (BorrowId.Map.mem bid reprs)); + assert (not (BorrowId.Map.mem bid infos)); (* Add the mapping for the representant *) - let reprs = V.BorrowId.Map.add bid bid reprs in + let reprs = BorrowId.Map.add bid bid reprs in (* Add the mapping for the loan info *) let info = { - loan_kind = T.Mut; + loan_kind = RMut; loan_in_abs; - loan_ids = V.BorrowId.Set.singleton bid; - borrow_ids = V.BorrowId.Set.empty; + loan_ids = BorrowId.Set.singleton bid; + borrow_ids = BorrowId.Set.empty; } in - let infos = V.BorrowId.Map.add bid info infos in + let infos = BorrowId.Map.add bid info infos in (* Update *) ids_reprs := reprs; borrows_infos := infos @@ -136,7 +126,7 @@ let check_loans_borrows_relation_invariant (ctx : C.eval_ctx) : unit = let loans_visitor = object - inherit [_] C.iter_eval_ctx as super + inherit [_] iter_eval_ctx as super method! visit_EBinding _ binder v = let inside_abs = false in @@ -161,7 +151,7 @@ let check_loans_borrows_relation_invariant (ctx : C.eval_ctx) : unit = match lc with | AMutLoan (bid, _) -> register_mut_loan inside_abs bid | ASharedLoan (bids, _, _) -> register_shared_loan inside_abs bids - | AIgnoredMutLoan (Some bid, _) -> register_ignored_loan T.Mut bid + | AIgnoredMutLoan (Some bid, _) -> register_ignored_loan RMut bid | AIgnoredMutLoan (None, _) | AIgnoredSharedLoan _ | AEndedMutLoan { given_back = _; child = _; given_back_meta = _ } @@ -182,27 +172,27 @@ let check_loans_borrows_relation_invariant (ctx : C.eval_ctx) : unit = (* Then, register all the borrows *) (* Some utilities to register the borrows *) - let find_info (bid : V.BorrowId.id) : borrow_info = + let find_info (bid : BorrowId.id) : borrow_info = (* Find the representant *) - match V.BorrowId.Map.find_opt bid !ids_reprs with + match BorrowId.Map.find_opt bid !ids_reprs with | Some repr_bid -> (* Lookup the info *) - V.BorrowId.Map.find repr_bid !borrows_infos + 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 () + ^ BorrowId.to_string bid ^ ":\nContext:\n" ^ context_to_string () in log#serror err; raise (Failure err) in - let update_info (bid : V.BorrowId.id) (info : borrow_info) : unit = + let update_info (bid : BorrowId.id) (info : borrow_info) : unit = (* Find the representant *) - let repr_bid = V.BorrowId.Map.find bid !ids_reprs in + let repr_bid = BorrowId.Map.find bid !ids_reprs in (* Update the info *) let infos = - V.BorrowId.Map.update repr_bid + BorrowId.Map.update repr_bid (fun x -> match x with | Some _ -> Some info @@ -214,39 +204,39 @@ let check_loans_borrows_relation_invariant (ctx : C.eval_ctx) : unit = let register_ignored_borrow = register_ignored_loan in - let register_borrow (kind : borrow_kind) (bid : V.BorrowId.id) : unit = + let register_borrow (kind : borrow_kind) (bid : 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 | Reserved) | T.Mut, Mut -> () + | RShared, (BShared | BReserved) | RMut, BMut -> () | _ -> raise (Failure "Invariant not satisfied")); (* A reserved borrow can't point to a value inside an abstraction *) - assert (kind <> Reserved || not info.loan_in_abs); + assert (kind <> BReserved || 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 + assert (not (BorrowId.Set.mem bid borrow_ids)); + let info = { info with borrow_ids = 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 + inherit [_] iter_eval_ctx as super method! visit_abstract_shared_borrow _ asb = match asb with - | V.AsbBorrow bid -> register_borrow Shared bid - | V.AsbProjReborrows _ -> () + | AsbBorrow bid -> register_borrow BShared bid + | AsbProjReborrows _ -> () method! visit_borrow_content env bc = (* Register the loan *) let _ = match bc with - | VSharedBorrow bid -> register_borrow Shared bid - | VMutBorrow (bid, _) -> register_borrow Mut bid - | VReservedMutBorrow bid -> register_borrow Reserved bid + | VSharedBorrow bid -> register_borrow BShared bid + | VMutBorrow (bid, _) -> register_borrow BMut bid + | VReservedMutBorrow bid -> register_borrow BReserved bid in (* Continue exploring *) super#visit_borrow_content env bc @@ -254,9 +244,9 @@ let check_loans_borrows_relation_invariant (ctx : C.eval_ctx) : unit = method! visit_aborrow_content env bc = let _ = match bc with - | AMutBorrow (bid, _) -> register_borrow Mut bid - | ASharedBorrow bid -> register_borrow Shared bid - | AIgnoredMutBorrow (Some bid, _) -> register_ignored_borrow Mut bid + | AMutBorrow (bid, _) -> register_borrow BMut bid + | ASharedBorrow bid -> register_borrow BShared bid + | AIgnoredMutBorrow (Some bid, _) -> register_ignored_borrow RMut bid | AIgnoredMutBorrow (None, _) | AEndedMutBorrow _ | AEndedIgnoredMutBorrow _ | AEndedSharedBorrow | AProjSharedBorrow _ -> @@ -284,26 +274,26 @@ let check_loans_borrows_relation_invariant (ctx : C.eval_ctx) : unit = !ignored_loans; (* Then, check the borrow infos *) - V.BorrowId.Map.iter + 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); + BorrowId.Set.elements info.loan_ids + = BorrowId.Set.elements info.borrow_ids); match info.loan_kind with - | T.Mut -> assert (V.BorrowId.Set.cardinal info.loan_ids = 1) - | T.Shared -> ()) + | RMut -> assert (BorrowId.Set.cardinal info.loan_ids = 1) + | RShared -> ()) !borrows_infos (** Check that: - borrows/loans can't contain ⊥ or reserved mut borrows - shared loans can't contain mutable loans *) -let check_borrowed_values_invariant (ctx : C.eval_ctx) : unit = +let check_borrowed_values_invariant (ctx : eval_ctx) : unit = let visitor = object - inherit [_] C.iter_eval_ctx as super + inherit [_] iter_eval_ctx as super method! visit_VBottom info = (* No ⊥ inside borrowed values *) @@ -377,13 +367,13 @@ let check_borrowed_values_invariant (ctx : C.eval_ctx) : unit = let info = { outer_borrow = false; outer_shared = false } in visitor#visit_eval_ctx info ctx -let check_literal_type (cv : V.literal) (ty : PV.literal_type) : unit = +let check_literal_type (cv : literal) (ty : literal_type) : unit = match (cv, ty) with - | PV.VScalar sv, PV.TInteger int_ty -> assert (sv.int_ty = int_ty) - | PV.VBool _, PV.TBool | PV.VChar _, PV.TChar -> () + | VScalar sv, TInteger int_ty -> assert (sv.int_ty = int_ty) + | VBool _, TBool | VChar _, TChar -> () | _ -> raise (Failure "Erroneous typing") -let check_typing_invariant (ctx : C.eval_ctx) : unit = +let check_typing_invariant (ctx : 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 @@ -391,14 +381,14 @@ let check_typing_invariant (ctx : C.eval_ctx) : unit = * we introduce this function, so that we can easily spot all the involved * places. * *) - let aloan_get_expected_child_type (ty : T.ty) : T.ty = + let aloan_get_expected_child_type (ty : ty) : ty = let _, ty, _ = ty_get_ref ty in ty in let visitor = object - inherit [_] C.iter_eval_ctx as super + inherit [_] iter_eval_ctx as super method! visit_abs _ abs = super#visit_abs (Some abs) abs method! visit_EBinding info binder v = @@ -421,7 +411,7 @@ let check_typing_invariant (ctx : C.eval_ctx) : unit = | VAdt av, TAdt (TAdtId def_id, generics) -> (* Retrieve the definition to check the variant id, the number of * parameters, etc. *) - let def = C.ctx_lookup_type_decl ctx def_id in + let def = ctx_lookup_type_decl ctx def_id in (* Check the number of parameters *) assert ( List.length generics.regions = List.length def.generics.regions); @@ -429,17 +419,17 @@ let check_typing_invariant (ctx : C.eval_ctx) : unit = (* Check that the variant id is consistent *) (match (av.variant_id, def.kind) with | Some variant_id, Enum variants -> - assert (T.VariantId.to_int variant_id < List.length variants) + assert (VariantId.to_int variant_id < List.length variants) | None, Struct _ -> () | _ -> raise (Failure "Erroneous typing")); (* Check that the field types are correct *) let field_types = - Assoc.type_decl_get_inst_norm_field_etypes ctx def av.variant_id - generics + AssociatedTypes.type_decl_get_inst_norm_field_etypes ctx def + av.variant_id generics in let fields_with_types = List.combine av.field_values field_types in List.iter - (fun ((v, ty) : V.typed_value * T.ty) -> assert (v.ty = ty)) + (fun ((v, ty) : typed_value * ty) -> assert (v.ty = ty)) fields_with_types (* Tuple case *) | VAdt av, TAdt (TTuple, generics) -> @@ -452,7 +442,7 @@ let check_typing_invariant (ctx : C.eval_ctx) : unit = List.combine av.field_values generics.types in List.iter - (fun ((v, ty) : V.typed_value * T.ty) -> assert (v.ty = ty)) + (fun ((v, ty) : typed_value * ty) -> assert (v.ty = ty)) fields_with_types (* Assumed type case *) | VAdt av, TAdt (TAssumed aty_id, generics) -> ( @@ -471,7 +461,7 @@ let check_typing_invariant (ctx : C.eval_ctx) : unit = (* *) assert ( List.for_all - (fun (v : V.typed_value) -> v.ty = inner_ty) + (fun (v : typed_value) -> v.ty = inner_ty) inner_values); (* The length is necessarily concrete *) let len = @@ -485,7 +475,7 @@ let check_typing_invariant (ctx : C.eval_ctx) : unit = | VBottom, _ -> (* Nothing to check *) () | VBorrow bc, TRef (_, ref_ty, rkind) -> ( match (bc, rkind) with - | VSharedBorrow bid, Shared | VReservedMutBorrow bid, Mut -> ( + | VSharedBorrow bid, RShared | VReservedMutBorrow bid, RMut -> ( (* Lookup the borrowed value to check it has the proper type *) let _, glc = lookup_loan ek_all bid ctx in match glc with @@ -493,7 +483,7 @@ let check_typing_invariant (ctx : C.eval_ctx) : unit = | Abstract (ASharedLoan (_, sv, _)) -> assert (sv.ty = ref_ty) | _ -> raise (Failure "Inconsistent context")) - | VMutBorrow (_, bv), Mut -> + | VMutBorrow (_, bv), RMut -> assert ( (* Check that the borrowed value has the proper type *) bv.ty = ref_ty) @@ -507,10 +497,10 @@ let check_typing_invariant (ctx : C.eval_ctx) : unit = match glc with | Concrete (VMutBorrow (_, bv)) -> assert (bv.ty = ty) | Abstract (AMutBorrow (_, sv)) -> - assert (Subst.erase_regions sv.ty = ty) + assert (Substitute.erase_regions sv.ty = ty) | _ -> raise (Failure "Inconsistent context"))) | VSymbolic sv, ty -> - let ty' = Subst.erase_regions sv.sv_ty in + let ty' = Substitute.erase_regions sv.sv_ty in assert (ty' = ty) | _ -> raise (Failure "Erroneous typing")); (* Continue exploring to inspect the subterms *) @@ -533,7 +523,7 @@ let check_typing_invariant (ctx : C.eval_ctx) : unit = | AAdt av, TAdt (TAdtId def_id, generics) -> (* Retrieve the definition to check the variant id, the number of * parameters, etc. *) - let def = C.ctx_lookup_type_decl ctx def_id in + let def = ctx_lookup_type_decl ctx def_id in (* Check the number of parameters *) assert ( List.length generics.regions = List.length def.generics.regions); @@ -544,17 +534,17 @@ let check_typing_invariant (ctx : C.eval_ctx) : unit = (* Check that the variant id is consistent *) (match (av.variant_id, def.kind) with | Some variant_id, Enum variants -> - assert (T.VariantId.to_int variant_id < List.length variants) + assert (VariantId.to_int variant_id < List.length variants) | None, Struct _ -> () | _ -> raise (Failure "Erroneous typing")); (* Check that the field types are correct *) let field_types = - Assoc.type_decl_get_inst_norm_field_rtypes ctx def av.variant_id - generics + AssociatedTypes.type_decl_get_inst_norm_field_rtypes ctx def + av.variant_id generics in let fields_with_types = List.combine av.field_values field_types in List.iter - (fun ((v, ty) : V.typed_avalue * T.ty) -> assert (v.ty = ty)) + (fun ((v, ty) : typed_avalue * ty) -> assert (v.ty = ty)) fields_with_types (* Tuple case *) | AAdt av, TAdt (TTuple, generics) -> @@ -567,7 +557,7 @@ let check_typing_invariant (ctx : C.eval_ctx) : unit = List.combine av.field_values generics.types in List.iter - (fun ((v, ty) : V.typed_avalue * T.ty) -> assert (v.ty = ty)) + (fun ((v, ty) : typed_avalue * ty) -> assert (v.ty = ty)) fields_with_types (* Assumed type case *) | AAdt av, TAdt (TAssumed aty_id, generics) -> ( @@ -586,23 +576,23 @@ let check_typing_invariant (ctx : C.eval_ctx) : unit = | ABottom, _ -> (* Nothing to check *) () | ABorrow bc, TRef (_, ref_ty, rkind) -> ( match (bc, rkind) with - | AMutBorrow (_, av), Mut -> + | AMutBorrow (_, av), RMut -> (* Check that the child value has the proper type *) assert (av.ty = ref_ty) - | ASharedBorrow bid, Shared -> ( + | ASharedBorrow bid, RShared -> ( (* Lookup the borrowed value to check it has the proper type *) let _, glc = lookup_loan ek_all bid ctx in match glc with | Concrete (VSharedLoan (_, sv)) | Abstract (ASharedLoan (_, sv, _)) -> - assert (sv.ty = Subst.erase_regions ref_ty) + assert (sv.ty = Substitute.erase_regions ref_ty) | _ -> raise (Failure "Inconsistent context")) - | AIgnoredMutBorrow (_opt_bid, av), Mut -> assert (av.ty = ref_ty) + | AIgnoredMutBorrow (_opt_bid, av), RMut -> assert (av.ty = ref_ty) | ( AEndedIgnoredMutBorrow { given_back; child; given_back_meta = _ }, - Mut ) -> + RMut ) -> assert (given_back.ty = ref_ty); assert (child.ty = ref_ty) - | AProjSharedBorrow _, Shared -> () + | AProjSharedBorrow _, RShared -> () | _ -> raise (Failure "Inconsistent context")) | ALoan lc, aty -> ( match lc with @@ -614,18 +604,18 @@ let check_typing_invariant (ctx : C.eval_ctx) : unit = let glc = lookup_borrow ek_all bid ctx in match glc with | Concrete (VMutBorrow (_, bv)) -> - assert (bv.ty = Subst.erase_regions borrowed_aty) + assert (bv.ty = Substitute.erase_regions borrowed_aty) | Abstract (AMutBorrow (_, sv)) -> assert ( - Subst.erase_regions sv.ty - = Subst.erase_regions borrowed_aty) + Substitute.erase_regions sv.ty + = Substitute.erase_regions borrowed_aty) | _ -> raise (Failure "Inconsistent context")) | AIgnoredMutLoan (None, child_av) -> let borrowed_aty = aloan_get_expected_child_type aty in assert (child_av.ty = borrowed_aty) | ASharedLoan (_, sv, child_av) | AEndedSharedLoan (sv, child_av) -> let borrowed_aty = aloan_get_expected_child_type aty in - assert (sv.ty = Subst.erase_regions borrowed_aty); + assert (sv.ty = Substitute.erase_regions borrowed_aty); (* TODO: the type of aloans doesn't make sense, see above *) assert (child_av.ty = borrowed_aty) | AEndedMutLoan { given_back; child; given_back_meta = _ } @@ -636,17 +626,17 @@ let check_typing_invariant (ctx : C.eval_ctx) : unit = | AIgnoredSharedLoan child_av -> assert (child_av.ty = aloan_get_expected_child_type aty)) | ASymbolic aproj, ty -> ( - let ty1 = Subst.erase_regions ty in + let ty1 = Substitute.erase_regions ty in match aproj with | AProjLoans (sv, _) -> - let ty2 = Subst.erase_regions sv.sv_ty in + let ty2 = Substitute.erase_regions sv.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.sv_ty) | AProjBorrows (sv, proj_ty) -> - let ty2 = Subst.erase_regions sv.sv_ty in + let ty2 = Substitute.erase_regions sv.sv_ty in assert (ty1 = ty2); (* Also check that the symbolic values contain regions of interest - * otherwise they should have been reduced to [_] *) @@ -656,7 +646,7 @@ let check_typing_invariant (ctx : C.eval_ctx) : unit = List.iter (fun (_, proj) -> match proj with - | V.AProjBorrows (_sv, ty') -> assert (ty' = ty) + | AProjBorrows (_sv, ty') -> assert (ty' = ty) | AEndedProjBorrows _ | AIgnoredProjBorrows -> () | _ -> raise (Failure "Unexpected")) given_back_ls @@ -665,34 +655,30 @@ let check_typing_invariant (ctx : C.eval_ctx) : unit = | _ -> log#lerror (lazy - ("Erroneous typing:" ^ "\n- raw value: " - ^ V.show_typed_avalue atv ^ "\n- value: " + ("Erroneous typing:" ^ "\n- raw value: " ^ show_typed_avalue atv + ^ "\n- value: " ^ typed_avalue_to_string ctx atv - ^ "\n- type: " - ^ PA.ty_to_string ctx atv.V.ty)); + ^ "\n- type: " ^ ty_to_string ctx atv.ty)); raise (Failure "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 + visitor#visit_eval_ctx (None : abs option) ctx type proj_borrows_info = { - abs_id : V.AbstractionId.id; - regions : T.RegionId.Set.t; - proj_ty : T.rty; (** The regions shouldn't be erased *) + abs_id : AbstractionId.id; + regions : RegionId.Set.t; + proj_ty : rty; (** The regions shouldn't be erased *) 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; -} +type proj_loans_info = { abs_id : AbstractionId.id; regions : RegionId.Set.t } [@@deriving show] type sv_info = { - ty : T.rty; (** The regions shouldn't be erased *) + ty : rty; (** The regions shouldn't be erased *) env_count : int; aproj_borrows : proj_borrows_info list; aproj_loans : proj_loans_info list; @@ -712,32 +698,32 @@ type sv_info = { - the union of the aproj_loans contains the aproj_borrows applied on the same symbolic values *) -let check_symbolic_values (ctx : C.eval_ctx) : unit = +let check_symbolic_values (ctx : eval_ctx) : unit = (* Small utility *) - let module M = V.SymbolicValueId.Map in + let module M = 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 + let lookup_info (sv : symbolic_value) : sv_info = + match M.find_opt sv.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) = + let update_info (sv : symbolic_value) (info : sv_info) = infos := M.add sv.sv_id info !infos in - let add_env_sv (sv : V.symbolic_value) : unit = + let add_env_sv (sv : 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 + let add_aproj_borrows (sv : 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 add_aproj_loans (sv : 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 @@ -746,14 +732,14 @@ let check_symbolic_values (ctx : C.eval_ctx) : unit = (* Visitor *) let obj = object - inherit [_] C.iter_eval_ctx as super + inherit [_] iter_eval_ctx as super method! visit_abs _ abs = super#visit_abs (Some abs) abs method! visit_VSymbolic _ sv = add_env_sv sv method! visit_abstract_shared_borrow abs asb = let abs = Option.get abs in match asb with - | V.AsbBorrow _ -> () + | AsbBorrow _ -> () | AsbProjReborrows (sv, proj_ty) -> add_aproj_borrows sv abs.abs_id abs.regions proj_ty true @@ -772,7 +758,7 @@ let check_symbolic_values (ctx : C.eval_ctx) : unit = log#ldebug (lazy ("check_symbolic_values: collected information:\n" - ^ V.SymbolicValueId.Map.to_string (Some " ") show_sv_info !infos)); + ^ SymbolicValueId.Map.to_string (Some " ") show_sv_info !infos)); (* Check *) let check_info _id info = (* TODO: check that: @@ -798,14 +784,14 @@ let check_symbolic_values (ctx : C.eval_ctx) : unit = List.fold_left (fun regions linfo -> let regions = - T.RegionId.Set.fold + RegionId.Set.fold (fun rid regions -> - assert (not (T.RegionId.Set.mem rid regions)); - T.RegionId.Set.add rid regions) + assert (not (RegionId.Set.mem rid regions)); + RegionId.Set.add rid regions) regions linfo.regions in regions) - T.RegionId.Set.empty info.aproj_loans + RegionId.Set.empty info.aproj_loans in (* Check that the union of the loan projectors contains the borrow projections. *) List.iter @@ -818,7 +804,7 @@ let check_symbolic_values (ctx : C.eval_ctx) : unit = M.iter check_info !infos -let check_invariants (ctx : C.eval_ctx) : unit = +let check_invariants (ctx : eval_ctx) : unit = if !Config.check_invariants then ( log#ldebug (lazy ("Checking invariants:\n" ^ eval_ctx_to_string ctx)); check_loans_borrows_relation_invariant ctx; diff --git a/compiler/LlbcAstUtils.ml b/compiler/LlbcAstUtils.ml index de46320b..01216157 100644 --- a/compiler/LlbcAstUtils.ml +++ b/compiler/LlbcAstUtils.ml @@ -1,3 +1,4 @@ +open Types open LlbcAst include Charon.LlbcAstUtils open Collections @@ -20,12 +21,6 @@ let lookup_fun_sig (fun_id : fun_id) (fun_decls : fun_decl FunDeclId.Map.t) : | FRegular id -> (FunDeclId.Map.find id fun_decls).signature | FAssumed aid -> Assumed.get_assumed_fun_sig aid -let lookup_fun_name (fun_id : fun_id) (fun_decls : fun_decl FunDeclId.Map.t) : - Names.fun_name = - match fun_id with - | FRegular id -> (FunDeclId.Map.find id fun_decls).name - | FAssumed aid -> Assumed.get_assumed_fun_name aid - (** Return the opaque declarations found in the crate, which are also *not builtin*. [filter_assumed]: if [true], do not consider as opaque the external definitions @@ -34,7 +29,7 @@ let lookup_fun_name (fun_id : fun_id) (fun_decls : fun_decl FunDeclId.Map.t) : Remark: the list of functions also contains the list of opaque global bodies. *) let crate_get_opaque_non_builtin_decls (k : crate) (filter_assumed : bool) : - T.type_decl list * fun_decl list = + type_decl list * fun_decl list = let open ExtractBuiltin in let is_opaque_fun (d : fun_decl) : bool = let sname = name_to_simple_name d.name in @@ -46,15 +41,15 @@ let crate_get_opaque_non_builtin_decls (k : crate) (filter_assumed : bool) : || (not (SimpleNameMap.mem sname builtin_globals_map)) && not (SimpleNameMap.mem sname (builtin_funs_map ()))) in - let is_opaque_type (d : T.type_decl) : bool = + let is_opaque_type (d : type_decl) : bool = let sname = name_to_simple_name d.name in - d.kind = T.Opaque + d.kind = Opaque && ((not filter_assumed) || not (SimpleNameMap.mem sname (builtin_types_map ()))) in (* Note that by checking the function bodies we also the globals *) - ( List.filter is_opaque_type (T.TypeDeclId.Map.values k.types), - List.filter is_opaque_fun (FunDeclId.Map.values k.functions) ) + ( List.filter is_opaque_type (TypeDeclId.Map.values k.type_decls), + List.filter is_opaque_fun (FunDeclId.Map.values k.fun_decls) ) (** Return true if the crate contains opaque declarations, ignoring the assumed definitions. *) diff --git a/compiler/Names.ml b/compiler/Names.ml deleted file mode 100644 index 97dbc180..00000000 --- a/compiler/Names.ml +++ /dev/null @@ -1 +0,0 @@ -include Charon.Names diff --git a/compiler/PrePasses.ml b/compiler/PrePasses.ml index 67063af9..c6b098e6 100644 --- a/compiler/PrePasses.ml +++ b/compiler/PrePasses.ml @@ -2,16 +2,13 @@ (concrete/symbolic) interpreter on it *) -module T = Types -module V = Values -module E = Expressions -module C = Contexts -module A = LlbcAst -module L = Logging +open Types +open Expressions +open LlbcAst open Utils open LlbcAstUtils -let log = L.pre_passes_log +let log = Logging.pre_passes_log (** Rustc inserts a lot of drops before the assignments. @@ -27,11 +24,11 @@ let log = L.pre_passes_log Rem.: we don't use this anymore *) -let filter_drop_assigns (f : A.fun_decl) : A.fun_decl = +let filter_drop_assigns (f : fun_decl) : fun_decl = (* The visitor *) let obj = object (self) - inherit [_] A.map_statement as super + inherit [_] map_statement as super method! visit_Sequence env st1 st2 = match (st1.content, st2.content) with @@ -91,7 +88,7 @@ let filter_drop_assigns (f : A.fun_decl) : A.fun_decl = restrictions on the rvalue), fake reads, drops (usually, returns will be followed by such statements) *) -let remove_useless_cf_merges (crate : A.crate) (f : A.fun_decl) : A.fun_decl = +let remove_useless_cf_merges (crate : crate) (f : fun_decl) : fun_decl = let f0 = f in (* Return [true] if the statement can be moved inside the branches of a switch. * @@ -99,8 +96,7 @@ let remove_useless_cf_merges (crate : A.crate) (f : A.fun_decl) : A.fun_decl = * (inside the encountered sequences) don't need to end with [return] or [panic], * but all the paths inside the whole statement have to. * *) - let rec can_be_moved_aux (must_end_with_exit : bool) (st : A.statement) : bool - = + let rec can_be_moved_aux (must_end_with_exit : bool) (st : statement) : bool = match st.content with | SetDiscriminant _ | Assert _ | Call _ | Break _ | Continue _ | Switch _ | Loop _ -> @@ -120,7 +116,7 @@ let remove_useless_cf_merges (crate : A.crate) (f : A.fun_decl) : A.fun_decl = (* The visitor *) let obj = object - inherit [_] A.map_statement as super + inherit [_] map_statement as super method! visit_Sequence env st1 st2 = match st1.content with @@ -189,14 +185,14 @@ let remove_useless_cf_merges (crate : A.crate) (f : A.fun_decl) : A.fun_decl = }; ]} *) -let remove_loop_breaks (crate : A.crate) (f : A.fun_decl) : A.fun_decl = +let remove_loop_breaks (crate : crate) (f : fun_decl) : fun_decl = let f0 = f in (* Check that a statement doesn't contain loops, breaks or continues *) - let statement_has_no_loop_break_continue (st : A.statement) : bool = + let statement_has_no_loop_break_continue (st : statement) : bool = let obj = object - inherit [_] A.iter_statement + inherit [_] iter_statement method! visit_Loop _ _ = raise Found method! visit_Break _ _ = raise Found method! visit_Continue _ _ = raise Found @@ -212,10 +208,10 @@ let remove_loop_breaks (crate : A.crate) (f : A.fun_decl) : A.fun_decl = break statement breaks exactly one level, and that there are no nested loops. *) - let replace_breaks_with (st : A.statement) (nst : A.statement) : A.statement = + let replace_breaks_with (st : statement) (nst : statement) : statement = let obj = object - inherit [_] A.map_statement as super + inherit [_] map_statement as super method! visit_Loop entered_loop loop = assert (not entered_loop); @@ -232,7 +228,7 @@ let remove_loop_breaks (crate : A.crate) (f : A.fun_decl) : A.fun_decl = (* The visitor *) let obj = object - inherit [_] A.map_statement as super + inherit [_] map_statement as super method! visit_Sequence env st1 st2 = match st1.content with @@ -365,27 +361,27 @@ let remove_loop_breaks (crate : A.crate) (f : A.fun_decl) : A.fun_decl = We then check that [x] completely disappeared from the function body (for sanity). *) -let remove_shallow_borrows (crate : A.crate) (f : A.fun_decl) : A.fun_decl = +let remove_shallow_borrows (crate : crate) (f : fun_decl) : fun_decl = let f0 = f in - let filter_in_body (body : A.statement) : A.statement = - let filtered = ref E.VarId.Set.empty in + let filter_in_body (body : statement) : statement = + let filtered = ref VarId.Set.empty in let filter_visitor = object - inherit [_] A.map_statement as super + inherit [_] map_statement as super method! visit_Assign env p rv = match (p.projection, rv) with - | [], E.RvRef (_, E.Shallow) -> + | [], RvRef (_, BShallow) -> (* Filter *) - filtered := E.VarId.Set.add p.var_id !filtered; + filtered := VarId.Set.add p.var_id !filtered; Nop | _ -> (* Don't filter *) super#visit_Assign env p rv method! visit_FakeRead env p = - if p.projection = [] && E.VarId.Set.mem p.var_id !filtered then + if p.projection = [] && VarId.Set.mem p.var_id !filtered then (* Filter *) Nop else super#visit_FakeRead env p @@ -398,8 +394,8 @@ let remove_shallow_borrows (crate : A.crate) (f : A.fun_decl) : A.fun_decl = (* Check that the filtered variables completely disappeared from the body *) let check_visitor = object - inherit [_] A.iter_statement - method! visit_var_id _ id = assert (not (E.VarId.Set.mem id !filtered)) + inherit [_] iter_statement + method! visit_var_id _ id = assert (not (VarId.Set.mem id !filtered)) end in check_visitor#visit_statement () body; @@ -423,14 +419,14 @@ let remove_shallow_borrows (crate : A.crate) (f : A.fun_decl) : A.fun_decl = ^ "\n")); f -let apply_passes (crate : A.crate) : A.crate = +let apply_passes (crate : crate) : crate = let passes = [ remove_loop_breaks crate; remove_shallow_borrows crate ] in - let functions = + let fun_decls = List.fold_left - (fun fl pass -> A.FunDeclId.Map.map pass fl) - crate.functions passes + (fun fl pass -> FunDeclId.Map.map pass fl) + crate.fun_decls passes in - let crate = { crate with functions } in + let crate = { crate with fun_decls } in log#ldebug (lazy ("After pre-passes:\n" ^ Print.Crate.crate_to_string crate ^ "\n")); crate diff --git a/compiler/Print.ml b/compiler/Print.ml index 28e940ba..cd83a589 100644 --- a/compiler/Print.ml +++ b/compiler/Print.ml @@ -1,8 +1,16 @@ include Charon.PrintUtils include Charon.PrintLlbcAst -module V = Values -module VU = ValuesUtils -module C = Contexts +open Charon.PrintPrimitiveValues +open Charon.PrintTypes +open Charon.PrintExpressions +open Charon.PrintLlbcAst.Ast +open Types +open TypesUtils +open Values +open ValuesUtils +open Expressions +open LlbcAst +open Contexts module PrimitiveValues = Charon.PrintPrimitiveValues module Types = Charon.PrintTypes module Expressions = Charon.PrintExpressions @@ -14,63 +22,28 @@ let bool_to_string (b : bool) : string = if b then "true" else "false" (** Pretty-printing for values *) module Values = struct - type value_formatter = { - region_id_to_string : T.RegionId.id -> string; - type_var_id_to_string : T.TypeVarId.id -> string; - type_decl_id_to_string : T.TypeDeclId.id -> string; - const_generic_var_id_to_string : T.ConstGenericVarId.id -> string; - global_decl_id_to_string : T.GlobalDeclId.id -> string; - trait_decl_id_to_string : T.TraitDeclId.id -> string; - trait_impl_id_to_string : T.TraitImplId.id -> string; - trait_clause_id_to_string : T.TraitClauseId.id -> string; - adt_variant_to_string : T.TypeDeclId.id -> T.VariantId.id -> string; - var_id_to_string : E.VarId.id -> string; - adt_field_names : - T.TypeDeclId.id -> T.VariantId.id option -> string list option; - } - - let value_to_type_formatter (fmt : value_formatter) : PT.type_formatter = - { - PT.region_id_to_string = fmt.region_id_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; - PT.const_generic_var_id_to_string = fmt.const_generic_var_id_to_string; - PT.global_decl_id_to_string = fmt.global_decl_id_to_string; - PT.trait_decl_id_to_string = fmt.trait_decl_id_to_string; - PT.trait_impl_id_to_string = fmt.trait_impl_id_to_string; - PT.trait_clause_id_to_string = fmt.trait_clause_id_to_string; - } - - let var_id_to_string (id : E.VarId.id) : string = - "var@" ^ E.VarId.to_string id + let symbolic_value_id_to_pretty_string (id : SymbolicValueId.id) : string = + "s@" ^ SymbolicValueId.to_string id - let symbolic_value_id_to_string (id : V.SymbolicValueId.id) : string = - "s@" ^ V.SymbolicValueId.to_string id + let symbolic_value_to_string (env : fmt_env) (sv : symbolic_value) : string = + symbolic_value_id_to_pretty_string sv.sv_id + ^ " : " ^ ty_to_string env sv.sv_ty - let symbolic_value_to_string (fmt : PT.type_formatter) (sv : V.symbolic_value) - : string = - symbolic_value_id_to_string sv.sv_id ^ " : " ^ PT.ty_to_string fmt sv.sv_ty - - let symbolic_value_proj_to_string (fmt : value_formatter) - (sv : V.symbolic_value) (rty : T.ty) : string = - let ty_fmt = value_to_type_formatter fmt in - symbolic_value_id_to_string sv.sv_id - ^ " : " - ^ PT.ty_to_string ty_fmt sv.sv_ty - ^ " <: " ^ PT.ty_to_string ty_fmt rty + let symbolic_value_proj_to_string (env : fmt_env) (sv : symbolic_value) + (rty : ty) : string = + symbolic_value_id_to_pretty_string sv.sv_id + ^ " : " ^ ty_to_string env sv.sv_ty ^ " <: " ^ ty_to_string env 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.type_formatter = value_to_type_formatter fmt in + let rec typed_value_to_string (env : fmt_env) (v : typed_value) : string = match v.value with - | VLiteral cv -> PPV.literal_to_string cv + | VLiteral cv -> literal_to_string cv | VAdt av -> ( let field_values = - List.map (typed_value_to_string fmt) av.field_values + List.map (typed_value_to_string env) av.field_values in match v.ty with | TAdt (TTuple, _) -> @@ -80,11 +53,11 @@ module Values = struct (* "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 + | Some vid -> adt_variant_to_string env def_id vid + | None -> type_decl_id_to_string env def_id in if List.length field_values > 0 then - match fmt.adt_field_names def_id av.V.variant_id with + match adt_field_names env def_id av.variant_id with | None -> let field_values = String.concat ", " field_values in adt_ident ^ " (" ^ field_values ^ ")" @@ -105,91 +78,84 @@ module Values = struct | TArray, _ -> (* Happens when we aggregate values *) "@Array[" ^ String.concat ", " field_values ^ "]" - | _ -> - raise (Failure ("Inconsistent value: " ^ V.show_typed_value v))) + | _ -> raise (Failure ("Inconsistent value: " ^ show_typed_value v)) + ) | _ -> raise (Failure "Inconsistent typed value")) - | VBottom -> "⊥ : " ^ PT.ty_to_string ty_fmt v.ty - | VBorrow bc -> borrow_content_to_string fmt bc - | VLoan lc -> loan_content_to_string fmt lc - | VSymbolic s -> symbolic_value_to_string ty_fmt s + | VBottom -> "⊥ : " ^ ty_to_string env v.ty + | VBorrow bc -> borrow_content_to_string env bc + | VLoan lc -> loan_content_to_string env lc + | VSymbolic s -> symbolic_value_to_string env s - and borrow_content_to_string (fmt : value_formatter) (bc : V.borrow_content) : - string = + and borrow_content_to_string (env : fmt_env) (bc : borrow_content) : string = match bc with - | VSharedBorrow bid -> "⌊shared@" ^ V.BorrowId.to_string bid ^ "⌋" + | VSharedBorrow bid -> "⌊shared@" ^ BorrowId.to_string bid ^ "⌋" | VMutBorrow (bid, tv) -> - "&mut@" ^ V.BorrowId.to_string bid ^ " (" - ^ typed_value_to_string fmt tv + "&mut@" ^ BorrowId.to_string bid ^ " (" + ^ typed_value_to_string env tv ^ ")" - | VReservedMutBorrow bid -> - "⌊reserved_mut@" ^ V.BorrowId.to_string bid ^ "⌋" + | VReservedMutBorrow bid -> "⌊reserved_mut@" ^ BorrowId.to_string bid ^ "⌋" - and loan_content_to_string (fmt : value_formatter) (lc : V.loan_content) : - string = + and loan_content_to_string (env : fmt_env) (lc : loan_content) : string = match lc with | VSharedLoan (loans, v) -> - let loans = V.BorrowId.Set.to_string None loans in - "@shared_loan(" ^ loans ^ ", " ^ typed_value_to_string fmt v ^ ")" - | VMutLoan bid -> "⌊mut@" ^ V.BorrowId.to_string bid ^ "⌋" + let loans = BorrowId.Set.to_string None loans in + "@shared_loan(" ^ loans ^ ", " ^ typed_value_to_string env v ^ ")" + | VMutLoan bid -> "⌊mut@" ^ BorrowId.to_string bid ^ "⌋" - let abstract_shared_borrow_to_string (fmt : value_formatter) - (abs : V.abstract_shared_borrow) : string = + let abstract_shared_borrow_to_string (env : fmt_env) + (abs : abstract_shared_borrow) : string = match abs with - | AsbBorrow bid -> V.BorrowId.to_string bid + | AsbBorrow bid -> BorrowId.to_string bid | AsbProjReborrows (sv, rty) -> - "{" ^ symbolic_value_proj_to_string fmt sv rty ^ "}" + "{" ^ symbolic_value_proj_to_string env sv rty ^ "}" - let abstract_shared_borrows_to_string (fmt : value_formatter) - (abs : V.abstract_shared_borrows) : string = + let abstract_shared_borrows_to_string (env : fmt_env) + (abs : abstract_shared_borrows) : string = "{" - ^ String.concat "," (List.map (abstract_shared_borrow_to_string fmt) abs) + ^ String.concat "," (List.map (abstract_shared_borrow_to_string env) abs) ^ "}" - let rec aproj_to_string (fmt : value_formatter) (pv : V.aproj) : string = + let rec aproj_to_string (env : fmt_env) (pv : 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 + let given_back = List.map (aproj_to_string env) given_back in " (" ^ String.concat "," given_back ^ ") " in - "⌊" - ^ symbolic_value_to_string (value_to_type_formatter fmt) sv - ^ given_back ^ "⌋" + "⌊" ^ symbolic_value_to_string env sv ^ given_back ^ "⌋" | AProjBorrows (sv, rty) -> - "(" ^ symbolic_value_proj_to_string fmt sv rty ^ ")" + "(" ^ symbolic_value_proj_to_string env 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 + let given_back = List.map (aproj_to_string env) 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.type_formatter = value_to_type_formatter fmt in + let rec typed_avalue_to_string (env : fmt_env) (v : typed_avalue) : string = match v.value with | AAdt av -> ( let field_values = - List.map (typed_avalue_to_string fmt) av.field_values + List.map (typed_avalue_to_string env) av.field_values in match v.ty with - | T.TAdt (T.TTuple, _) -> + | TAdt (TTuple, _) -> (* Tuple *) "(" ^ String.concat ", " field_values ^ ")" - | T.TAdt (T.TAdtId def_id, _) -> + | TAdt (TAdtId 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 + | Some vid -> adt_variant_to_string env def_id vid + | None -> type_decl_id_to_string env def_id in if List.length field_values > 0 then - match fmt.adt_field_names def_id av.V.variant_id with + match adt_field_names env def_id av.variant_id with | None -> let field_values = String.concat ", " field_values in adt_ident ^ " (" ^ field_values ^ ")" @@ -203,133 +169,130 @@ module Values = struct let field_values = String.concat " " field_values in adt_ident ^ " { " ^ field_values ^ " }" else adt_ident - | T.TAdt (T.TAssumed aty, _) -> ( + | TAdt (TAssumed aty, _) -> ( (* Assumed type *) match (aty, field_values) with | TBox, [ bv ] -> "@Box(" ^ bv ^ ")" | _ -> raise (Failure "Inconsistent value")) | _ -> raise (Failure "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 + | ABottom -> "⊥ : " ^ ty_to_string env v.ty + | ABorrow bc -> aborrow_content_to_string env bc + | ALoan lc -> aloan_content_to_string env lc + | ASymbolic s -> aproj_to_string env s | AIgnored -> "_" - and aloan_content_to_string (fmt : value_formatter) (lc : V.aloan_content) : - string = + and aloan_content_to_string (env : fmt_env) (lc : aloan_content) : string = match lc with | AMutLoan (bid, av) -> - "⌊mut@" ^ V.BorrowId.to_string bid ^ ", " - ^ typed_avalue_to_string fmt av + "⌊mut@" ^ BorrowId.to_string bid ^ ", " + ^ typed_avalue_to_string env av ^ "⌋" | ASharedLoan (loans, v, av) -> - let loans = V.BorrowId.Set.to_string None loans in + let loans = BorrowId.Set.to_string None loans in "@shared_loan(" ^ loans ^ ", " - ^ typed_value_to_string fmt v + ^ typed_value_to_string env v ^ ", " - ^ typed_avalue_to_string fmt av + ^ typed_avalue_to_string env av ^ ")" | AEndedMutLoan ml -> "@ended_mut_loan{" - ^ typed_avalue_to_string fmt ml.child + ^ typed_avalue_to_string env ml.child ^ "; " - ^ typed_avalue_to_string fmt ml.given_back + ^ typed_avalue_to_string env ml.given_back ^ " }" | AEndedSharedLoan (v, av) -> "@ended_shared_loan(" - ^ typed_value_to_string fmt v + ^ typed_value_to_string env v ^ ", " - ^ typed_avalue_to_string fmt av + ^ typed_avalue_to_string env av ^ ")" | AIgnoredMutLoan (opt_bid, av) -> "@ignored_mut_loan(" - ^ option_to_string V.BorrowId.to_string opt_bid + ^ option_to_string BorrowId.to_string opt_bid ^ ", " - ^ typed_avalue_to_string fmt av + ^ typed_avalue_to_string env av ^ ")" | AEndedIgnoredMutLoan ml -> "@ended_ignored_mut_loan{ " - ^ typed_avalue_to_string fmt ml.child + ^ typed_avalue_to_string env ml.child ^ "; " - ^ typed_avalue_to_string fmt ml.given_back + ^ typed_avalue_to_string env ml.given_back ^ "}" | AIgnoredSharedLoan sl -> - "@ignored_shared_loan(" ^ typed_avalue_to_string fmt sl ^ ")" + "@ignored_shared_loan(" ^ typed_avalue_to_string env sl ^ ")" - and aborrow_content_to_string (fmt : value_formatter) (bc : V.aborrow_content) - : string = + and aborrow_content_to_string (env : fmt_env) (bc : aborrow_content) : string + = match bc with | AMutBorrow (bid, av) -> - "&mut@" ^ V.BorrowId.to_string bid ^ " (" - ^ typed_avalue_to_string fmt av + "&mut@" ^ BorrowId.to_string bid ^ " (" + ^ typed_avalue_to_string env av ^ ")" - | ASharedBorrow bid -> "⌊shared@" ^ V.BorrowId.to_string bid ^ "⌋" + | ASharedBorrow bid -> "⌊shared@" ^ BorrowId.to_string bid ^ "⌋" | AIgnoredMutBorrow (opt_bid, av) -> "@ignored_mut_borrow(" - ^ option_to_string V.BorrowId.to_string opt_bid + ^ option_to_string BorrowId.to_string opt_bid ^ ", " - ^ typed_avalue_to_string fmt av + ^ typed_avalue_to_string env av ^ ")" | AEndedMutBorrow (_mv, child) -> - "@ended_mut_borrow(" ^ typed_avalue_to_string fmt child ^ ")" + "@ended_mut_borrow(" ^ typed_avalue_to_string env child ^ ")" | AEndedIgnoredMutBorrow { child; given_back; given_back_meta = _ } -> "@ended_ignored_mut_borrow{ " - ^ typed_avalue_to_string fmt child + ^ typed_avalue_to_string env child ^ "; " - ^ typed_avalue_to_string fmt given_back + ^ typed_avalue_to_string env given_back ^ ")" | AEndedSharedBorrow -> "@ended_shared_borrow" | AProjSharedBorrow sb -> "@ignored_shared_borrow(" - ^ abstract_shared_borrows_to_string fmt sb + ^ abstract_shared_borrows_to_string env sb ^ ")" - let loop_abs_kind_to_string (kind : V.loop_abs_kind) : string = + let loop_abs_kind_to_string (kind : loop_abs_kind) : string = match kind with | LoopSynthInput -> "LoopSynthInput" | LoopCall -> "LoopCall" - let abs_kind_to_string (kind : V.abs_kind) : string = + let abs_kind_to_string (kind : abs_kind) : string = match kind with - | V.FunCall (fid, rg_id) -> - "FunCall(fid:" ^ V.FunCallId.to_string fid ^ ", rg_id:" - ^ T.RegionGroupId.to_string rg_id + | FunCall (fid, rg_id) -> + "FunCall(fid:" ^ FunCallId.to_string fid ^ ", rg_id:" + ^ RegionGroupId.to_string rg_id ^ ")" | SynthInput rg_id -> - "SynthInput(rg_id:" ^ T.RegionGroupId.to_string rg_id ^ ")" - | SynthRet rg_id -> - "SynthRet(rg_id:" ^ T.RegionGroupId.to_string rg_id ^ ")" + "SynthInput(rg_id:" ^ RegionGroupId.to_string rg_id ^ ")" + | SynthRet rg_id -> "SynthRet(rg_id:" ^ RegionGroupId.to_string rg_id ^ ")" | Loop (lp_id, rg_id, abs_kind) -> - "Loop(loop_id:" ^ V.LoopId.to_string lp_id ^ ", rg_id:" - ^ option_to_string T.RegionGroupId.to_string rg_id + "Loop(loop_id:" ^ LoopId.to_string lp_id ^ ", rg_id:" + ^ option_to_string RegionGroupId.to_string rg_id ^ ", loop abs kind: " ^ loop_abs_kind_to_string abs_kind ^ ")" | Identity -> "Identity" - let abs_to_string (fmt : value_formatter) (verbose : bool) (indent : string) - (indent_incr : string) (abs : V.abs) : string = + let abs_to_string (env : fmt_env) (verbose : bool) (indent : string) + (indent_incr : string) (abs : abs) : string = let indent2 = indent ^ indent_incr in let avs = - List.map (fun av -> indent2 ^ typed_avalue_to_string fmt av) abs.avalues + List.map (fun av -> indent2 ^ typed_avalue_to_string env av) abs.avalues in let avs = String.concat ",\n" avs in let kind = if verbose then "[kind:" ^ abs_kind_to_string abs.kind ^ "]" else "" in indent ^ "abs@" - ^ V.AbstractionId.to_string abs.abs_id + ^ AbstractionId.to_string abs.abs_id ^ kind ^ "{parents=" - ^ V.AbstractionId.Set.to_string None abs.parents + ^ AbstractionId.Set.to_string None abs.parents ^ "}" ^ "{regions=" - ^ T.RegionId.Set.to_string None abs.regions + ^ RegionId.Set.to_string None abs.regions ^ "}" ^ " {\n" ^ avs ^ "\n" ^ indent ^ "}" - let inst_fun_sig_to_string (fmt : value_formatter) (sg : LlbcAst.inst_fun_sig) - : string = + let inst_fun_sig_to_string (env : fmt_env) (sg : LlbcAst.inst_fun_sig) : + string = (* TODO: print the trait type constraints? *) - let ty_fmt = value_to_type_formatter fmt in - let ty_to_string = PT.ty_to_string ty_fmt in + let ty_to_string = ty_to_string env in let inputs = "(" ^ String.concat ", " (List.map ty_to_string sg.inputs) ^ ")" @@ -338,71 +301,67 @@ module Values = struct inputs ^ " -> " ^ output end -module PV = Values (* local module *) - (** Pretty-printing for contexts *) module Contexts = struct - let var_binder_to_string (bv : C.var_binder) : string = + open Values + + let var_binder_to_string (env : fmt_env) (bv : var_binder) : string = match bv.name with - | None -> PV.var_id_to_string bv.index - | Some name -> name ^ "^" ^ E.VarId.to_string bv.index + | None -> var_id_to_string env bv.index + | Some name -> name ^ "^" ^ VarId.to_string bv.index - let dummy_var_id_to_string (bid : C.DummyVarId.id) : string = - "_@" ^ C.DummyVarId.to_string bid + let dummy_var_id_to_string (bid : DummyVarId.id) : string = + "_@" ^ DummyVarId.to_string bid - let binder_to_string (bv : C.binder) : string = + let binder_to_string (env : fmt_env) (bv : binder) : string = match bv with - | BVar b -> var_binder_to_string b + | BVar b -> var_binder_to_string env b | BDummy bid -> dummy_var_id_to_string bid - let env_elem_to_string (fmt : PV.value_formatter) (verbose : bool) + let env_elem_to_string (env : fmt_env) (verbose : bool) (with_var_types : bool) (indent : string) (indent_incr : string) - (ev : C.env_elem) : string = + (ev : env_elem) : string = match ev with | EBinding (var, tv) -> - let bv = binder_to_string var in + let bv = binder_to_string env var in let ty = - if with_var_types then - " : " ^ PT.ty_to_string (PV.value_to_type_formatter fmt) tv.V.ty - else "" + if with_var_types then " : " ^ ty_to_string env tv.ty else "" in - indent ^ bv ^ ty ^ " -> " ^ PV.typed_value_to_string fmt tv ^ " ;" - | EAbs abs -> PV.abs_to_string fmt verbose indent indent_incr abs + indent ^ bv ^ ty ^ " -> " ^ typed_value_to_string env tv ^ " ;" + | EAbs abs -> abs_to_string env verbose indent indent_incr abs | EFrame -> raise (Failure "Can't print a Frame element") - let opt_env_elem_to_string (fmt : PV.value_formatter) (verbose : bool) + let opt_env_elem_to_string (env : fmt_env) (verbose : bool) (with_var_types : bool) (indent : string) (indent_incr : string) - (ev : C.env_elem option) : string = + (ev : env_elem option) : string = match ev with | None -> indent ^ "..." | Some ev -> - env_elem_to_string fmt verbose with_var_types indent indent_incr ev + env_elem_to_string env verbose with_var_types 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 = + let filter_env (env : env) : 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 = + let filter_elem (ev : env_elem) : env_elem option = match ev with | EBinding (BVar _, tv) -> (* Not a dummy binding: check if the value is ⊥ *) - if VU.is_bottom tv.value then None else Some ev + if is_bottom tv.value then None else Some ev | EBinding (BDummy _, 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 + if borrows_in_value tv || 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 = + let rec group_filtered (env : env_elem option list) : env_elem option list = match env with | [] -> [] | None :: None :: env -> group_filtered (None :: env) @@ -415,8 +374,8 @@ module Contexts = struct "..." to gain space and clarity. [with_var_types]: if true, print the type of the variables *) - let env_to_string (filter : bool) (fmt : PV.value_formatter) (verbose : bool) - (with_var_types : bool) (env : C.env) : string = + let env_to_string (filter : bool) (fmt_env : fmt_env) (verbose : bool) + (with_var_types : bool) (env : env) : string = let env = if filter then filter_env env else List.map (fun ev -> Some ev) env in @@ -424,124 +383,70 @@ module Contexts = struct ^ String.concat "\n" (List.map (fun ev -> - opt_env_elem_to_string fmt verbose with_var_types " " " " ev) + opt_env_elem_to_string fmt_env verbose with_var_types " " " " ev) env) ^ "\n}" - type ctx_formatter = PV.value_formatter - - let ast_to_ctx_formatter (fmt : PA.ast_formatter) : ctx_formatter = + let decls_ctx_to_fmt_env (ctx : decls_ctx) : fmt_env = + let type_decls = ctx.type_ctx.type_decls in + let fun_decls = ctx.fun_ctx.fun_decls in + let global_decls = ctx.global_ctx.global_decls in + let trait_decls = ctx.trait_decls_ctx.trait_decls in + let trait_impls = ctx.trait_impls_ctx.trait_impls in + let generics = TypesUtils.empty_generic_params in + let preds = TypesUtils.empty_predicates in { - PV.region_id_to_string = fmt.region_id_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.const_generic_var_id_to_string = fmt.const_generic_var_id_to_string; - PV.global_decl_id_to_string = fmt.global_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; - PV.trait_decl_id_to_string = fmt.trait_decl_id_to_string; - PV.trait_impl_id_to_string = fmt.trait_impl_id_to_string; - PV.trait_clause_id_to_string = fmt.trait_clause_id_to_string; + type_decls; + fun_decls; + global_decls; + trait_decls; + trait_impls; + generics; + preds; + locals = []; } - let ast_to_value_formatter (fmt : PA.ast_formatter) : PV.value_formatter = - ast_to_ctx_formatter fmt - - let ctx_to_type_formatter (fmt : ctx_formatter) : PT.type_formatter = - PV.value_to_type_formatter fmt - - let eval_ctx_to_ctx_formatter (ctx : C.eval_ctx) : ctx_formatter = - let region_id_to_string r = PT.region_id_to_string r in - - let type_var_id_to_string vid = - (* The context may be invalid *) - match C.lookup_type_var_opt ctx vid with - | None -> T.TypeVarId.to_string vid - | Some v -> v.name - in - let const_generic_var_id_to_string vid = - match C.lookup_const_generic_var_opt ctx vid with - | None -> T.ConstGenericVarId.to_string vid - | Some v -> 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 global_decl_id_to_string def_id = - let def = C.ctx_lookup_global_decl ctx def_id in - name_to_string def.name - in - let trait_decl_id_to_string def_id = - let def = C.ctx_lookup_trait_decl ctx def_id in - name_to_string def.name + let eval_ctx_to_fmt_env (ctx : eval_ctx) : fmt_env = + 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 trait_decls = ctx.trait_decls_context.trait_decls in + let trait_impls = ctx.trait_impls_context.trait_impls in + (* Below: it is always safe to omit fields - if an id can't be found at + printing time, we print the id (in raw form) instead of the name it + designates. *) + let generics : generic_params = + { + types = ctx.type_vars; + (* The regions have been transformed to region groups *) + regions = []; + const_generics = ctx.const_generic_vars; + (* We don't need the trait clauses so we initialize them to empty *) + trait_clauses = []; + } in - let trait_impl_id_to_string def_id = - let def = C.ctx_lookup_trait_impl ctx def_id in - name_to_string def.name - in - let trait_clause_id_to_string id = PT.trait_clause_id_to_pretty_string id in - let adt_variant_to_string = - PT.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_var_binder ctx vid in - var_binder_to_string bv - in - let adt_field_names = - PT.type_ctx_to_adt_field_names_fun ctx.type_context.type_decls - in - { - region_id_to_string; - type_var_id_to_string; - type_decl_id_to_string; - const_generic_var_id_to_string; - global_decl_id_to_string; - adt_variant_to_string; - var_id_to_string; - adt_field_names; - trait_decl_id_to_string; - trait_impl_id_to_string; - trait_clause_id_to_string; - } - - let eval_ctx_to_ast_formatter (ctx : C.eval_ctx) : PA.ast_formatter = - let ctx_fmt = eval_ctx_to_ctx_formatter ctx in - let adt_field_to_string = - PT.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 - let trait_decl_id_to_string def_id = - let def = C.ctx_lookup_trait_decl ctx def_id in - name_to_string def.name - in - let trait_impl_id_to_string def_id = - let def = C.ctx_lookup_trait_impl ctx def_id in - name_to_string def.name + (* We don't need the predicates so we initialize them to empty *) + let preds = empty_predicates in + (* For the locals: we retrieve the information from the environment. + Note that the locals don't need to be ordered based on their indices. + *) + let rec env_to_locals (env : env) : (VarId.id * string option) list = + match env with + | [] | EFrame :: _ -> [] + | EAbs _ :: env -> env_to_locals env + | EBinding (BVar b, _) :: env -> (b.index, b.name) :: env_to_locals env + | EBinding (BDummy _, _) :: env -> env_to_locals env in - let trait_clause_id_to_string id = PT.trait_clause_id_to_pretty_string id in + let locals = env_to_locals ctx.env in { - region_id_to_string = ctx_fmt.PV.region_id_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; - const_generic_var_id_to_string = ctx_fmt.PV.const_generic_var_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; - trait_decl_id_to_string; - trait_impl_id_to_string; - trait_clause_id_to_string; + type_decls; + fun_decls; + global_decls; + trait_decls; + trait_impls; + generics; + preds; + locals; } (** Split an [env] at every occurrence of [Frame], eliminating those elements. @@ -550,8 +455,8 @@ module Contexts = struct * 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) = + let split_env_according_to_frames (env : env) : env list = + let rec split_aux (frames : env list) (curr_frame : env) (env : env) = match env with | [] -> if List.length curr_frame > 0 then curr_frame :: frames else frames @@ -561,9 +466,10 @@ module Contexts = struct let frames = split_aux [] [] env in frames - let fmt_eval_ctx_to_string_gen (fmt : ctx_formatter) (verbose : bool) - (filter : bool) (with_var_types : bool) (ctx : C.eval_ctx) : string = - let ended_regions = T.RegionId.Set.to_string None ctx.ended_regions in + let eval_ctx_to_string_gen (verbose : bool) (filter : bool) + (with_var_types : bool) (ctx : eval_ctx) : string = + let fmt_env = eval_ctx_to_fmt_env ctx in + let ended_regions = 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 = @@ -575,149 +481,139 @@ module Contexts = struct List.iter (fun ev -> match ev with - | C.EBinding (BDummy _, _) -> num_dummies := !num_abs + 1 - | C.EBinding (BVar _, _) -> num_bindings := !num_bindings + 1 - | C.EAbs _ -> num_abs := !num_abs + 1 + | EBinding (BDummy _, _) -> num_dummies := !num_abs + 1 + | EBinding (BVar _, _) -> num_bindings := !num_bindings + 1 + | EAbs _ -> 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 filter fmt verbose with_var_types f + ^ env_to_string filter fmt_env verbose with_var_types f ^ "\n") frames in "# Ended regions: " ^ ended_regions ^ "\n" ^ "# " ^ string_of_int num_frames ^ " frame(s)\n" ^ String.concat "" frames - let eval_ctx_to_string_gen (verbose : bool) (filter : bool) - (with_var_types : bool) (ctx : C.eval_ctx) : string = - let fmt = eval_ctx_to_ctx_formatter ctx in - fmt_eval_ctx_to_string_gen fmt verbose filter with_var_types ctx - - let eval_ctx_to_string (ctx : C.eval_ctx) : string = + let eval_ctx_to_string (ctx : eval_ctx) : string = eval_ctx_to_string_gen false true true ctx - let eval_ctx_to_string_no_filter (ctx : C.eval_ctx) : string = + let eval_ctx_to_string_no_filter (ctx : eval_ctx) : string = eval_ctx_to_string_gen false false true ctx end -module PC = Contexts (* local module *) - (** Pretty-printing for LLBC ASTs (functions based on an evaluation context) *) -module EvalCtxLlbcAst = struct - let ty_to_string (ctx : C.eval_ctx) (t : T.ty) : string = - let fmt = PC.eval_ctx_to_ctx_formatter ctx in - let fmt = PC.ctx_to_type_formatter fmt in - PT.ty_to_string fmt t +module EvalCtx = struct + open Values + open Contexts - let generic_params_to_strings (ctx : C.eval_ctx) (x : T.generic_params) : - string list * string list = - let fmt = PC.eval_ctx_to_ctx_formatter ctx in - let fmt = PC.ctx_to_type_formatter fmt in - PT.generic_params_to_strings fmt x + let name_to_string (ctx : eval_ctx) (n : name) : string = + let env = eval_ctx_to_fmt_env ctx in + name_to_string env n - let generic_args_to_string (ctx : C.eval_ctx) (x : T.generic_args) : string = - let fmt = PC.eval_ctx_to_ctx_formatter ctx in - let fmt = PC.ctx_to_type_formatter fmt in - PT.generic_args_to_string fmt x + let ty_to_string (ctx : eval_ctx) (t : ty) : string = + let env = eval_ctx_to_fmt_env ctx in + ty_to_string env t - let trait_ref_to_string (ctx : C.eval_ctx) (x : T.trait_ref) : string = - let fmt = PC.eval_ctx_to_ctx_formatter ctx in - let fmt = PC.ctx_to_type_formatter fmt in - PT.trait_ref_to_string fmt x + let generic_params_to_strings (ctx : eval_ctx) (x : generic_params) : + string list * string list = + let env = eval_ctx_to_fmt_env ctx in + generic_params_to_strings env x - let trait_instance_id_to_string (ctx : C.eval_ctx) (x : T.trait_instance_id) : - string = - let fmt = PC.eval_ctx_to_ctx_formatter ctx in - let fmt = PC.ctx_to_type_formatter fmt in - PT.trait_instance_id_to_string fmt x + let generic_args_to_string (ctx : eval_ctx) (x : generic_args) : string = + let env = eval_ctx_to_fmt_env ctx in + generic_args_to_string env x + + let trait_ref_to_string (ctx : eval_ctx) (x : trait_ref) : string = + let env = eval_ctx_to_fmt_env ctx in + trait_ref_to_string env x - let borrow_content_to_string (ctx : C.eval_ctx) (bc : V.borrow_content) : + let trait_instance_id_to_string (ctx : eval_ctx) (x : trait_instance_id) : string = - let fmt = PC.eval_ctx_to_ctx_formatter ctx in - PV.borrow_content_to_string fmt bc + let env = eval_ctx_to_fmt_env ctx in + trait_instance_id_to_string env x - 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 borrow_content_to_string (ctx : eval_ctx) (bc : borrow_content) : string = + let env = eval_ctx_to_fmt_env ctx in + borrow_content_to_string env bc - 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 loan_content_to_string (ctx : eval_ctx) (lc : loan_content) : string = + let env = eval_ctx_to_fmt_env ctx in + loan_content_to_string env lc - let aloan_content_to_string (ctx : C.eval_ctx) (lc : V.aloan_content) : string + let aborrow_content_to_string (ctx : eval_ctx) (bc : aborrow_content) : string = - let fmt = PC.eval_ctx_to_ctx_formatter ctx in - PV.aloan_content_to_string fmt lc + let env = eval_ctx_to_fmt_env ctx in + aborrow_content_to_string env bc - 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 aloan_content_to_string (ctx : eval_ctx) (lc : aloan_content) : string = + let env = eval_ctx_to_fmt_env ctx in + aloan_content_to_string env lc - 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_type_formatter fmt in - PV.symbolic_value_to_string fmt sv + let aproj_to_string (ctx : eval_ctx) (p : aproj) : string = + let env = eval_ctx_to_fmt_env ctx in + aproj_to_string env p + + let symbolic_value_to_string (ctx : eval_ctx) (sv : symbolic_value) : string = + let env = eval_ctx_to_fmt_env ctx in + symbolic_value_to_string env 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_value_to_string (ctx : eval_ctx) (v : typed_value) : string = + let env = eval_ctx_to_fmt_env ctx in + typed_value_to_string env 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 typed_avalue_to_string (ctx : eval_ctx) (v : typed_avalue) : string = + let env = eval_ctx_to_fmt_env ctx in + typed_avalue_to_string env v - let place_to_string (ctx : C.eval_ctx) (op : E.place) : string = - let fmt = PC.eval_ctx_to_ast_formatter ctx in - PE.place_to_string fmt op + let place_to_string (ctx : eval_ctx) (op : place) : string = + let env = eval_ctx_to_fmt_env ctx in + place_to_string env op - let operand_to_string (ctx : C.eval_ctx) (op : E.operand) : string = - let fmt = PC.eval_ctx_to_ast_formatter ctx in - PE.operand_to_string fmt op + let operand_to_string (ctx : eval_ctx) (op : operand) : string = + let env = eval_ctx_to_fmt_env ctx in + operand_to_string env op - let call_to_string (ctx : C.eval_ctx) (call : A.call) : string = - let fmt = PC.eval_ctx_to_ast_formatter ctx in - PA.call_to_string fmt "" call + let call_to_string (ctx : eval_ctx) (call : call) : string = + let env = eval_ctx_to_fmt_env ctx in + call_to_string env "" call - let fun_decl_to_string (ctx : C.eval_ctx) (f : A.fun_decl) : string = - let fmt = PC.eval_ctx_to_ast_formatter ctx in - PA.fun_decl_to_string fmt "" " " f + let fun_decl_to_string (ctx : eval_ctx) (f : fun_decl) : string = + let env = eval_ctx_to_fmt_env ctx in + fun_decl_to_string env "" " " f - let fun_sig_to_string (ctx : C.eval_ctx) (x : A.fun_sig) : string = - let fmt = PC.eval_ctx_to_ast_formatter ctx in - PA.fun_sig_to_string fmt "" " " x + let fun_sig_to_string (ctx : eval_ctx) (x : fun_sig) : string = + let env = eval_ctx_to_fmt_env ctx in + fun_sig_to_string env "" " " x - let inst_fun_sig_to_string (ctx : C.eval_ctx) (x : LlbcAst.inst_fun_sig) : + let inst_fun_sig_to_string (ctx : eval_ctx) (x : LlbcAst.inst_fun_sig) : string = - let fmt = PC.eval_ctx_to_ast_formatter ctx in - let fmt = PC.ast_to_value_formatter fmt in - PV.inst_fun_sig_to_string fmt x - - let fun_id_or_trait_method_ref_to_string (ctx : C.eval_ctx) - (x : E.fun_id_or_trait_method_ref) : string = - let fmt = PC.eval_ctx_to_ast_formatter ctx in - PE.fun_id_or_trait_method_ref_to_string fmt x "..." - - let statement_to_string (ctx : C.eval_ctx) (indent : string) - (indent_incr : string) (e : A.statement) : string = - let fmt = PC.eval_ctx_to_ast_formatter ctx in - PA.statement_to_string fmt indent indent_incr e - - let trait_impl_to_string (ctx : C.eval_ctx) (timpl : A.trait_impl) : string = - let fmt = PC.eval_ctx_to_ast_formatter ctx in - PA.trait_impl_to_string fmt " " " " timpl - - let env_elem_to_string (ctx : C.eval_ctx) (indent : string) - (indent_incr : string) (ev : C.env_elem) : string = - let fmt = PC.eval_ctx_to_ctx_formatter ctx in - PC.env_elem_to_string fmt false true indent indent_incr ev - - let abs_to_string (ctx : C.eval_ctx) (indent : string) (indent_incr : string) - (abs : V.abs) : string = - let fmt = PC.eval_ctx_to_ctx_formatter ctx in - PV.abs_to_string fmt false indent indent_incr abs + let env = eval_ctx_to_fmt_env ctx in + inst_fun_sig_to_string env x + + let fun_id_or_trait_method_ref_to_string (ctx : eval_ctx) + (x : fun_id_or_trait_method_ref) : string = + let env = eval_ctx_to_fmt_env ctx in + fun_id_or_trait_method_ref_to_string env x "..." + + let statement_to_string (ctx : eval_ctx) (indent : string) + (indent_incr : string) (e : statement) : string = + let env = eval_ctx_to_fmt_env ctx in + statement_to_string env indent indent_incr e + + let trait_impl_to_string (ctx : eval_ctx) (timpl : trait_impl) : string = + let env = eval_ctx_to_fmt_env ctx in + trait_impl_to_string env " " " " timpl + + let env_elem_to_string (ctx : eval_ctx) (indent : string) + (indent_incr : string) (ev : env_elem) : string = + let env = eval_ctx_to_fmt_env ctx in + env_elem_to_string env false true indent indent_incr ev + + let abs_to_string (ctx : eval_ctx) (indent : string) (indent_incr : string) + (abs : abs) : string = + let env = eval_ctx_to_fmt_env ctx in + abs_to_string env false indent indent_incr abs end diff --git a/compiler/PrintPure.ml b/compiler/PrintPure.ml index 8b737cb5..e6686951 100644 --- a/compiler/PrintPure.ml +++ b/compiler/PrintPure.ml @@ -3,80 +3,102 @@ open Pure open PureUtils -type type_formatter = { - type_var_id_to_string : TypeVarId.id -> string; - type_decl_id_to_string : TypeDeclId.id -> string; - const_generic_var_id_to_string : ConstGenericVarId.id -> string; - global_decl_id_to_string : GlobalDeclId.id -> string; - trait_decl_id_to_string : TraitDeclId.id -> string; - trait_impl_id_to_string : TraitImplId.id -> string; - trait_clause_id_to_string : TraitClauseId.id -> string; +(** The formatting context for pure definitions uses non-pure definitions + to lookup names. The main reason is that when building the pure definitions + like in [SymbolicToPure] we don't have a pure context available, while + at every stage we have the original LLBC definitions at hand. + *) +type fmt_env = { + type_decls : Types.type_decl TypeDeclId.Map.t; + fun_decls : LlbcAst.fun_decl FunDeclId.Map.t; + global_decls : LlbcAst.global_decl GlobalDeclId.Map.t; + trait_decls : LlbcAst.trait_decl TraitDeclId.Map.t; + trait_impls : LlbcAst.trait_impl TraitImplId.Map.t; + generics : generic_params; + locals : (VarId.id * string option) list; } -type value_formatter = { - type_var_id_to_string : TypeVarId.id -> string; - type_decl_id_to_string : TypeDeclId.id -> string; - const_generic_var_id_to_string : ConstGenericVarId.id -> string; - global_decl_id_to_string : GlobalDeclId.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; - trait_decl_id_to_string : TraitDeclId.id -> string; - trait_impl_id_to_string : TraitImplId.id -> string; - trait_clause_id_to_string : TraitClauseId.id -> string; -} +let var_id_to_pretty_string (id : var_id) : string = "v@" ^ VarId.to_string id + +let type_var_id_to_string (env : fmt_env) (id : type_var_id) : string = + (* Note that the types are not necessarily ordered following their indices *) + match + List.find_opt (fun (x : type_var) -> x.index = id) env.generics.types + with + | None -> Print.Types.type_var_id_to_pretty_string id + | Some x -> Print.Types.type_var_to_string x -let value_to_type_formatter (fmt : value_formatter) : type_formatter = +let const_generic_var_id_to_string (env : fmt_env) (id : const_generic_var_id) : + string = + (* Note that the regions are not necessarily ordered following their indices *) + match + List.find_opt + (fun (x : const_generic_var) -> x.index = id) + env.generics.const_generics + with + | None -> Print.Types.const_generic_var_id_to_pretty_string id + | Some x -> Print.Types.const_generic_var_to_string x + +let var_id_to_string (env : fmt_env) (id : VarId.id) : string = + match List.find_opt (fun (i, _) -> i = id) env.locals with + | None -> var_id_to_pretty_string id + | Some (_, name) -> ( + match name with + | None -> var_id_to_pretty_string id + | Some name -> name ^ "^" ^ VarId.to_string id) + +let trait_clause_id_to_string = Print.Types.trait_clause_id_to_string + +let fmt_env_to_llbc_fmt_env (env : fmt_env) : Print.fmt_env = { - type_var_id_to_string = fmt.type_var_id_to_string; - type_decl_id_to_string = fmt.type_decl_id_to_string; - const_generic_var_id_to_string = fmt.const_generic_var_id_to_string; - global_decl_id_to_string = fmt.global_decl_id_to_string; - trait_decl_id_to_string = fmt.trait_decl_id_to_string; - trait_impl_id_to_string = fmt.trait_impl_id_to_string; - trait_clause_id_to_string = fmt.trait_clause_id_to_string; + type_decls = env.type_decls; + fun_decls = env.fun_decls; + global_decls = env.global_decls; + trait_decls = env.trait_decls; + trait_impls = env.trait_impls; + generics = TypesUtils.empty_generic_params; + preds = TypesUtils.empty_predicates; + locals = []; } -(* 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; - const_generic_var_id_to_string : ConstGenericVarId.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; - trait_decl_id_to_string : TraitDeclId.id -> string; - trait_impl_id_to_string : TraitImplId.id -> string; - trait_clause_id_to_string : TraitClauseId.id -> string; -} - -let ast_to_value_formatter (fmt : ast_formatter) : value_formatter = +let decls_ctx_to_fmt_env (ctx : Contexts.decls_ctx) : fmt_env = { - type_var_id_to_string = fmt.type_var_id_to_string; - type_decl_id_to_string = fmt.type_decl_id_to_string; - const_generic_var_id_to_string = fmt.const_generic_var_id_to_string; - global_decl_id_to_string = fmt.global_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; - trait_decl_id_to_string = fmt.trait_decl_id_to_string; - trait_impl_id_to_string = fmt.trait_impl_id_to_string; - trait_clause_id_to_string = fmt.trait_clause_id_to_string; + type_decls = ctx.type_ctx.type_decls; + fun_decls = ctx.fun_ctx.fun_decls; + global_decls = ctx.global_ctx.global_decls; + trait_decls = ctx.trait_decls_ctx.trait_decls; + trait_impls = ctx.trait_impls_ctx.trait_impls; + generics = empty_generic_params; + locals = []; } -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 (env : fmt_env) = + Print.Types.name_to_string (fmt_env_to_llbc_fmt_env env) + +let type_decl_id_to_string (env : fmt_env) = + Print.Types.type_decl_id_to_string (fmt_env_to_llbc_fmt_env env) + +let global_decl_id_to_string (env : fmt_env) = + Print.Types.global_decl_id_to_string (fmt_env_to_llbc_fmt_env env) + +let fun_decl_id_to_string (env : fmt_env) = + Print.Expressions.fun_decl_id_to_string (fmt_env_to_llbc_fmt_env env) + +let trait_decl_id_to_string (env : fmt_env) = + Print.Types.trait_decl_id_to_string (fmt_env_to_llbc_fmt_env env) + +let trait_impl_id_to_string (env : fmt_env) = + Print.Types.trait_impl_id_to_string (fmt_env_to_llbc_fmt_env env) + +let adt_field_to_string (env : fmt_env) = + Print.Types.adt_field_to_string (fmt_env_to_llbc_fmt_env env) + +let adt_variant_from_type_decl_id_to_string (env : fmt_env) = + Print.Types.adt_variant_to_string (fmt_env_to_llbc_fmt_env env) + +let adt_field_names (env : fmt_env) = + Print.Types.adt_field_names (fmt_env_to_llbc_fmt_env env) -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 const_generic_var_to_string = Print.Types.const_generic_var_to_string @@ -85,110 +107,6 @@ let literal_type_to_string = Print.PrimitiveValues.literal_type_to_string let scalar_value_to_string = Print.PrimitiveValues.scalar_value_to_string let literal_to_string = Print.PrimitiveValues.literal_to_string -(* Remark: not using generic_params on purpose, because we may use parameters - which either come from LLBC or from pure, and the [generic_params] type - for those ASTs is not the same. Note that it works because we actually don't - need to know the trait clauses to print the AST: we can thus ignore them. -*) -let mk_type_formatter (type_decls : T.type_decl TypeDeclId.Map.t) - (global_decls : A.global_decl GlobalDeclId.Map.t) - (trait_decls : A.trait_decl TraitDeclId.Map.t) - (trait_impls : A.trait_impl TraitImplId.Map.t) (type_params : type_var list) - (const_generic_params : const_generic_var list) : type_formatter = - let type_var_id_to_string vid = - let var = TypeVarId.nth type_params vid in - type_var_to_string var - in - let const_generic_var_id_to_string vid = - let var = ConstGenericVarId.nth const_generic_params vid in - const_generic_var_to_string var - in - let type_decl_id_to_string def_id = - let def = TypeDeclId.Map.find def_id type_decls in - name_to_string def.name - in - let global_decl_id_to_string def_id = - let def = GlobalDeclId.Map.find def_id global_decls in - name_to_string def.name - in - let trait_decl_id_to_string def_id = - let def = TraitDeclId.Map.find def_id trait_decls in - name_to_string def.name - in - let trait_impl_id_to_string def_id = - let def = TraitImplId.Map.find def_id trait_impls in - name_to_string def.name - in - let trait_clause_id_to_string id = - Print.PT.trait_clause_id_to_pretty_string id - in - { - type_var_id_to_string; - type_decl_id_to_string; - const_generic_var_id_to_string; - global_decl_id_to_string; - trait_decl_id_to_string; - trait_impl_id_to_string; - trait_clause_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) - (trait_decls : A.trait_decl TraitDeclId.Map.t) - (trait_impls : A.trait_impl TraitImplId.Map.t) (type_params : type_var list) - (const_generic_params : const_generic_var list) : ast_formatter = - let ({ - type_var_id_to_string; - type_decl_id_to_string; - const_generic_var_id_to_string; - global_decl_id_to_string; - trait_decl_id_to_string; - trait_impl_id_to_string; - trait_clause_id_to_string; - } - : type_formatter) = - mk_type_formatter type_decls global_decls trait_decls trait_impls - type_params const_generic_params - in - let adt_variant_to_string = - Print.Types.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.Types.type_ctx_to_adt_field_names_fun type_decls - in - let adt_field_to_string = - Print.Types.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 - { - type_var_id_to_string; - const_generic_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; - trait_decl_id_to_string; - trait_impl_id_to_string; - trait_clause_id_to_string; - } - let assumed_ty_to_string (aty : assumed_ty) : string = match aty with | TState -> "State" @@ -201,137 +119,135 @@ let assumed_ty_to_string (aty : assumed_ty) : string = | TRawPtr Mut -> "MutRawPtr" | TRawPtr Const -> "ConstRawPtr" -let type_id_to_string (fmt : type_formatter) (id : type_id) : string = +let type_id_to_string (env : fmt_env) (id : type_id) : string = match id with - | TAdtId id -> fmt.type_decl_id_to_string id + | TAdtId id -> type_decl_id_to_string env id | TTuple -> "" | TAssumed aty -> assumed_ty_to_string aty (* TODO: duplicates Charon.PrintTypes.const_generic_to_string *) -let const_generic_to_string (fmt : type_formatter) (cg : T.const_generic) : - string = +let const_generic_to_string (env : fmt_env) (cg : const_generic) : string = match cg with - | CGGlobal id -> fmt.global_decl_id_to_string id - | CGVar id -> fmt.const_generic_var_id_to_string id + | CGGlobal id -> global_decl_id_to_string env id + | CGVar id -> const_generic_var_id_to_string env id | CGValue lit -> literal_to_string lit -let rec ty_to_string (fmt : type_formatter) (inside : bool) (ty : ty) : string = +let rec ty_to_string (env : fmt_env) (inside : bool) (ty : ty) : string = match ty with | TAdt (id, generics) -> ( match id with | TTuple -> - let generics = generic_args_to_strings fmt false generics in + let generics = generic_args_to_strings env false generics in "(" ^ String.concat " * " generics ^ ")" | TAdtId _ | TAssumed _ -> - let generics = generic_args_to_strings fmt true generics in + let generics = generic_args_to_strings env true generics in let generics_s = if generics = [] then "" else " " ^ String.concat " " generics in - let ty_s = type_id_to_string fmt id ^ generics_s in + let ty_s = type_id_to_string env id ^ generics_s in if generics <> [] && inside then "(" ^ ty_s ^ ")" else ty_s) - | TVar tv -> fmt.type_var_id_to_string tv + | TVar tv -> type_var_id_to_string env tv | TLiteral lty -> literal_type_to_string lty | TArrow (arg_ty, ret_ty) -> let ty = - ty_to_string fmt true arg_ty ^ " -> " ^ ty_to_string fmt false ret_ty + ty_to_string env true arg_ty ^ " -> " ^ ty_to_string env false ret_ty in if inside then "(" ^ ty ^ ")" else ty | TTraitType (trait_ref, generics, type_name) -> - let trait_ref = trait_ref_to_string fmt false trait_ref in + let trait_ref = trait_ref_to_string env false trait_ref in let s = if generics = empty_generic_args then trait_ref ^ "::" ^ type_name else - let generics = generic_args_to_string fmt generics in + let generics = generic_args_to_string env generics in "(" ^ trait_ref ^ " " ^ generics ^ ")::" ^ type_name in if inside then "(" ^ s ^ ")" else s -and generic_args_to_strings (fmt : type_formatter) (inside : bool) +and generic_args_to_strings (env : fmt_env) (inside : bool) (generics : generic_args) : string list = - let tys = List.map (ty_to_string fmt inside) generics.types in - let cgs = List.map (const_generic_to_string fmt) generics.const_generics in + let tys = List.map (ty_to_string env inside) generics.types in + let cgs = List.map (const_generic_to_string env) generics.const_generics in let trait_refs = - List.map (trait_ref_to_string fmt inside) generics.trait_refs + List.map (trait_ref_to_string env inside) generics.trait_refs in List.concat [ tys; cgs; trait_refs ] -and generic_args_to_string (fmt : type_formatter) (generics : generic_args) : - string = - String.concat " " (generic_args_to_strings fmt true generics) +and generic_args_to_string (env : fmt_env) (generics : generic_args) : string = + String.concat " " (generic_args_to_strings env true generics) -and trait_ref_to_string (fmt : type_formatter) (inside : bool) (tr : trait_ref) - : string = - let trait_id = trait_instance_id_to_string fmt false tr.trait_id in - let generics = generic_args_to_string fmt tr.generics in +and trait_ref_to_string (env : fmt_env) (inside : bool) (tr : trait_ref) : + string = + let trait_id = trait_instance_id_to_string env false tr.trait_id in + let generics = generic_args_to_string env tr.generics in let s = trait_id ^ generics in if tr.generics = empty_generic_args || not inside then s else "(" ^ s ^ ")" -and trait_instance_id_to_string (fmt : type_formatter) (inside : bool) +and trait_instance_id_to_string (env : fmt_env) (inside : bool) (id : trait_instance_id) : string = match id with | Self -> "Self" - | TraitImpl id -> fmt.trait_impl_id_to_string id - | Clause id -> fmt.trait_clause_id_to_string id + | TraitImpl id -> trait_impl_id_to_string env id + | Clause id -> trait_clause_id_to_string env id | ParentClause (inst_id, _decl_id, clause_id) -> - let inst_id = trait_instance_id_to_string fmt false inst_id in - let clause_id = fmt.trait_clause_id_to_string clause_id in + let inst_id = trait_instance_id_to_string env false inst_id in + let clause_id = trait_clause_id_to_string env clause_id in "parent(" ^ inst_id ^ ")::" ^ clause_id | ItemClause (inst_id, _decl_id, item_name, clause_id) -> - let inst_id = trait_instance_id_to_string fmt false inst_id in - let clause_id = fmt.trait_clause_id_to_string clause_id in + let inst_id = trait_instance_id_to_string env false inst_id in + let clause_id = trait_clause_id_to_string env clause_id in "(" ^ inst_id ^ ")::" ^ item_name ^ "::[" ^ clause_id ^ "]" - | TraitRef tr -> trait_ref_to_string fmt inside tr + | TraitRef tr -> trait_ref_to_string env inside tr | UnknownTrait msg -> "UNKNOWN(" ^ msg ^ ")" -let trait_clause_to_string (fmt : type_formatter) (clause : trait_clause) : - string = - let clause_id = fmt.trait_clause_id_to_string clause.clause_id in - let trait_id = fmt.trait_decl_id_to_string clause.trait_id in - let generics = generic_args_to_strings fmt true clause.generics in +let trait_clause_to_string (env : fmt_env) (clause : trait_clause) : string = + let clause_id = trait_clause_id_to_string env clause.clause_id in + let trait_id = trait_decl_id_to_string env clause.trait_id in + let generics = generic_args_to_strings env true clause.generics in let generics = if generics = [] then "" else " " ^ String.concat " " generics in "[" ^ clause_id ^ "]: " ^ trait_id ^ generics -let generic_params_to_strings (fmt : type_formatter) (generics : generic_params) - : string list = +let generic_params_to_strings (env : fmt_env) (generics : generic_params) : + string list = let tys = List.map type_var_to_string generics.types in let cgs = List.map const_generic_var_to_string generics.const_generics in let trait_clauses = - List.map (trait_clause_to_string fmt) generics.trait_clauses + List.map (trait_clause_to_string env) generics.trait_clauses in List.concat [ tys; cgs; trait_clauses ] -let field_to_string fmt inside (f : field) : string = +let field_to_string env inside (f : field) : string = match f.field_name with - | None -> ty_to_string fmt inside f.field_ty + | None -> ty_to_string env inside f.field_ty | Some field_name -> - let s = field_name ^ " : " ^ ty_to_string fmt false f.field_ty in + let s = field_name ^ " : " ^ ty_to_string env false f.field_ty in if inside then "(" ^ s ^ ")" else s -let variant_to_string fmt (v : variant) : string = +let variant_to_string env (v : variant) : string = v.variant_name ^ "(" - ^ String.concat ", " (List.map (field_to_string fmt false) v.fields) + ^ String.concat ", " (List.map (field_to_string env false) v.fields) ^ ")" -let type_decl_to_string (fmt : type_formatter) (def : type_decl) : string = - let name = name_to_string def.name in +let type_decl_to_string (env : fmt_env) (def : type_decl) : string = + let env = { env with generics = def.generics } in + let name = def.name in let params = if def.generics = empty_generic_params then "" - else " " ^ String.concat " " (generic_params_to_strings fmt def.generics) + else " " ^ String.concat " " (generic_params_to_strings env def.generics) 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 false f) fields) + (List.map (fun f -> "\n " ^ field_to_string env false 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 + List.map (fun v -> "| " ^ variant_to_string env v) variants in let variants = String.concat "\n" variants in "enum " ^ name ^ params ^ " =\n" ^ variants @@ -342,48 +258,50 @@ let var_to_varname (v : var) : string = | 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 var_to_string (env : fmt_env) (v : var) : string = let varname = var_to_varname v in - "(" ^ varname ^ " : " ^ ty_to_string fmt false v.ty ^ ")" + "(" ^ varname ^ " : " ^ ty_to_string env false v.ty ^ ")" -let rec mprojection_to_string (fmt : ast_formatter) (inside : string) +let rec mprojection_to_string (env : fmt_env) (inside : string) (p : mprojection) : string = match p with | [] -> inside | pe :: p' -> ( - let s = mprojection_to_string fmt inside p' in + let s = mprojection_to_string env inside p' in match pe.pkind with | 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 + match adt_field_to_string env 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 + let variant_name = + adt_variant_from_type_decl_id_to_string env adt_id variant_id + in "(" ^ s ^ " as " ^ variant_name ^ ")." ^ field_name)) -let mplace_to_string (fmt : ast_formatter) (p : mplace) : string = +let mplace_to_string (env : fmt_env) (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 ^ "^" ^ E.VarId.to_string p.var_id ^ "llbc" in - mprojection_to_string fmt name p.projection + mprojection_to_string env name p.projection -let adt_variant_to_string (fmt : value_formatter) (adt_id : type_id) +let adt_variant_to_string (env : fmt_env) (adt_id : type_id) (variant_id : VariantId.id option) : string = match adt_id with | TTuple -> "Tuple" | TAdtId 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) + | Some vid -> adt_variant_from_type_decl_id_to_string env def_id vid + | None -> type_decl_id_to_string env def_id) | TAssumed aty -> ( (* Assumed type *) match aty with @@ -407,7 +325,7 @@ let adt_variant_to_string (fmt : value_formatter) (adt_id : type_id) else if variant_id = fuel_succ_id then "@Fuel::Succ" else raise (Failure "Unreachable: improper variant id for fuel type")) -let adt_field_to_string (fmt : value_formatter) (adt_id : type_id) +let adt_field_to_string (env : fmt_env) (adt_id : type_id) (field_id : FieldId.id) : string = match adt_id with | TTuple -> @@ -415,7 +333,7 @@ let adt_field_to_string (fmt : value_formatter) (adt_id : type_id) (* Tuples don't use the opaque field id for the field indices, but [int] *) | TAdtId def_id -> ( (* "Regular" ADT *) - let fields = fmt.adt_field_names def_id None in + let fields = adt_field_names env def_id None in match fields with | None -> FieldId.to_string field_id | Some fields -> FieldId.nth fields field_id) @@ -432,9 +350,9 @@ let adt_field_to_string (fmt : value_formatter) (adt_id : type_id) (** TODO: we don't need a general function anymore (it is now only used for 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 adt_g_value_to_string (env : fmt_env) (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 | TAdt (TTuple, _) -> @@ -444,11 +362,11 @@ let adt_g_value_to_string (fmt : value_formatter) (* "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 + | Some vid -> adt_variant_from_type_decl_id_to_string env def_id vid + | None -> type_decl_id_to_string env def_id in if field_values <> [] then - match fmt.adt_field_names def_id variant_id with + match adt_field_names env def_id variant_id with | None -> let field_values = String.concat ", " field_values in adt_ident ^ " (" ^ field_values ^ ")" @@ -504,42 +422,38 @@ let adt_g_value_to_string (fmt : value_formatter) let id = assumed_ty_to_string aty in id ^ " [" ^ 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 false ty ^ "\n- variant_id: " + ^ "\n- ty: " ^ ty_to_string env false 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 = +let rec typed_pattern_to_string (env : fmt_env) (v : typed_pattern) : string = match v.value with | PatConstant cv -> literal_to_string cv - | PatVar (v, None) -> var_to_string (ast_to_type_formatter fmt) v + | PatVar (v, None) -> var_to_string env v | PatVar (v, Some mp) -> - let mp = "[@mplace=" ^ mplace_to_string fmt mp ^ "]" in + let mp = "[@mplace=" ^ mplace_to_string env mp ^ "]" in "(" ^ var_to_varname v ^ " " ^ mp ^ " : " - ^ ty_to_string (ast_to_type_formatter fmt) false v.ty + ^ ty_to_string env false v.ty ^ ")" | PatDummy -> "_" | PatAdt av -> - adt_g_value_to_string - (ast_to_value_formatter fmt) - (typed_pattern_to_string fmt) + adt_g_value_to_string env + (typed_pattern_to_string env) 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 generics = generic_params_to_strings ty_fmt sg.generics in - let inputs = List.map (ty_to_string ty_fmt false) sg.inputs in - let output = ty_to_string ty_fmt false sg.output in +let fun_sig_to_string (env : fmt_env) (sg : fun_sig) : string = + let env = { env with generics = sg.generics } in + let generics = generic_params_to_strings env sg.generics in + let inputs = List.map (ty_to_string env false) sg.inputs in + let output = ty_to_string env false sg.output in let all_types = List.concat [ generics; 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 false) sg.inputs in - let output = ty_to_string ty_fmt false sg.output in +let inst_fun_sig_to_string (env : fmt_env) (sg : inst_fun_sig) : string = + let inputs = List.map (ty_to_string env false) sg.inputs in + let output = ty_to_string env false sg.output in let all_types = List.append inputs [ output ] in String.concat " -> " all_types @@ -568,10 +482,14 @@ let llbc_assumed_fun_id_to_string (fid : A.assumed_fun_id) : string = | ArrayToSliceShared -> "@ArrayToSliceShared" | ArrayToSliceMut -> "@ArrayToSliceMut" | ArrayRepeat -> "@ArrayRepeat" - | SliceLen -> "@SliceLen" | SliceIndexShared -> "@SliceIndexShared" | SliceIndexMut -> "@SliceIndexMut" +let llbc_fun_id_to_string (env : fmt_env) (fid : A.fun_id) : string = + match fid with + | FRegular fid -> fun_decl_id_to_string env fid + | FAssumed fid -> llbc_assumed_fun_id_to_string fid + let pure_assumed_fun_id_to_string (fid : pure_assumed_fun_id) : string = match fid with | Return -> "return" @@ -580,16 +498,15 @@ let pure_assumed_fun_id_to_string (fid : pure_assumed_fun_id) : string = | FuelDecrease -> "fuel_decrease" | FuelEqZero -> "fuel_eq_zero" -let regular_fun_id_to_string (fmt : ast_formatter) (fun_id : fun_id) : string = +let regular_fun_id_to_string (env : fmt_env) (fun_id : fun_id) : string = match fun_id with | FromLlbc (fid, lp_id, rg_id) -> let f = match fid with - | FunId (FRegular fid) -> fmt.fun_decl_id_to_string fid + | FunId (FRegular fid) -> fun_decl_id_to_string env fid | FunId (FAssumed fid) -> llbc_assumed_fun_id_to_string fid | TraitMethod (trait_ref, method_name, _) -> - let fmt = ast_to_type_formatter fmt in - trait_ref_to_string fmt true trait_ref ^ "." ^ method_name + trait_ref_to_string env true trait_ref ^ "." ^ method_name in f ^ fun_suffix lp_id rg_id | Pure fid -> pure_assumed_fun_id_to_string fid @@ -604,60 +521,59 @@ let unop_to_string (unop : unop) : string = let binop_to_string = Print.Expressions.binop_to_string -let fun_or_op_id_to_string (fmt : ast_formatter) (fun_id : fun_or_op_id) : - string = +let fun_or_op_id_to_string (env : fmt_env) (fun_id : fun_or_op_id) : string = match fun_id with - | Fun fun_id -> regular_fun_id_to_string fmt fun_id + | Fun fun_id -> regular_fun_id_to_string env fun_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 = +let rec texpression_to_string (env : fmt_env) (inside : bool) (indent : string) + (indent_incr : string) (e : texpression) : string = match e.e with - | Var var_id -> fmt.var_id_to_string var_id - | CVar cg_id -> fmt.const_generic_var_id_to_string cg_id + | Var var_id -> var_id_to_string env var_id + | CVar cg_id -> const_generic_var_id_to_string env cg_id | Const cv -> literal_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 + app_to_string env 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 + let e = abs_to_string env 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 [] + app_to_string env inside indent indent_incr e [] | Let (monadic, lv, re, e) -> - let e = let_to_string fmt indent indent_incr monadic lv re e in + let e = let_to_string env 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 + let e = switch_to_string env indent indent_incr scrutinee body in if inside then "(" ^ e ^ ")" else e | Loop loop -> - let e = loop_to_string fmt indent indent_incr loop in + let e = loop_to_string env indent indent_incr loop in if inside then "(" ^ e ^ ")" else e | StructUpdate supd -> ( let s = match supd.init with | None -> "" - | Some vid -> " " ^ fmt.var_id_to_string vid ^ " with" + | Some vid -> " " ^ var_id_to_string env vid ^ " with" in let indent1 = indent ^ indent_incr in let indent2 = indent1 ^ indent_incr in (* The id should be a custom type decl id or an array *) match supd.struct_id with | TAdtId aid -> - let field_names = Option.get (fmt.adt_field_names aid None) in + let field_names = Option.get (adt_field_names env aid None) in let fields = List.map (fun (fid, fe) -> let field = FieldId.nth field_names fid in let fe = - texpression_to_string fmt false indent2 indent_incr fe + texpression_to_string env false indent2 indent_incr fe in "\n" ^ indent1 ^ field ^ " := " ^ fe ^ ";") supd.updates @@ -668,21 +584,21 @@ let rec texpression_to_string (fmt : ast_formatter) (inside : bool) let fields = List.map (fun (_, fe) -> - texpression_to_string fmt false indent2 indent_incr fe) + texpression_to_string env false indent2 indent_incr fe) supd.updates in "[ " ^ String.concat ", " fields ^ " ]" | _ -> raise (Failure "Unexpected")) | Meta (meta, e) -> ( - let meta_s = meta_to_string fmt meta in - let e = texpression_to_string fmt inside indent indent_incr e in + let meta_s = meta_to_string env meta in + let e = texpression_to_string env inside indent indent_incr e in match meta with | Assignment _ | SymbolicAssignment _ | Tag _ -> 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) +and app_to_string (env : fmt_env) (inside : bool) (indent : string) (indent_incr : string) (app : texpression) (args : texpression list) : string = (* There are two possibilities: either the [app] is an instantiated, @@ -692,40 +608,37 @@ and app_to_string (fmt : ast_formatter) (inside : bool) (indent : string) match app.e with | Qualif qualif -> (* Qualifier case *) - let ty_fmt = ast_to_type_formatter fmt in (* Convert the qualifier identifier *) let qualif_s = match qualif.id with - | FunOrOp fun_id -> fun_or_op_id_to_string fmt fun_id - | Global global_id -> fmt.global_decl_id_to_string global_id + | FunOrOp fun_id -> fun_or_op_id_to_string env fun_id + | Global global_id -> global_decl_id_to_string env 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 + adt_variant_to_string env 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 + let adt_s = adt_variant_to_string env adt_id None in + let field_s = adt_field_to_string env adt_id field_id in (* Adopting an F*-like syntax *) ConstStrings.constructor_prefix ^ adt_s ^ "?." ^ field_s | TraitConst (trait_ref, generics, const_name) -> - let trait_ref = trait_ref_to_string ty_fmt true trait_ref in - let generics_s = generic_args_to_string ty_fmt generics in + let trait_ref = trait_ref_to_string env true trait_ref in + let generics_s = generic_args_to_string env generics in if generics <> empty_generic_args then "(" ^ trait_ref ^ generics_s ^ ")." ^ const_name else trait_ref ^ "." ^ const_name in (* Convert the type instantiation *) - let generics = generic_args_to_strings ty_fmt true qualif.generics in + let generics = generic_args_to_strings env true qualif.generics in (* *) (qualif_s, generics) | _ -> (* "Regular" expression case *) let inside = args <> [] || (args = [] && inside) in - (texpression_to_string fmt inside indent indent_incr app, []) + (texpression_to_string env inside indent indent_incr app, []) in (* Convert the arguments. * The arguments are expressions, so indentation might get weird... (though @@ -733,7 +646,7 @@ and app_to_string (fmt : ast_formatter) (inside : bool) (indent : string) let arg_to_string = let inside = true in let indent1 = indent ^ indent_incr in - texpression_to_string fmt inside indent1 indent_incr + texpression_to_string env inside indent1 indent_incr in let args = List.map arg_to_string args in let all_args = List.append generics args in @@ -744,32 +657,31 @@ and app_to_string (fmt : ast_formatter) (inside : bool) (indent : string) (* Add parentheses *) if all_args <> [] && inside then "(" ^ e ^ ")" else e -and abs_to_string (fmt : ast_formatter) (indent : string) (indent_incr : string) +and abs_to_string (env : fmt_env) (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 + let xl = List.map (typed_pattern_to_string env) xl in + let e = texpression_to_string env false indent indent_incr e in "λ " ^ String.concat " " xl ^ ". " ^ e -and let_to_string (fmt : ast_formatter) (indent : string) (indent_incr : string) +and let_to_string (env : fmt_env) (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 + let re = texpression_to_string env inside indent1 indent_incr re in + let e = texpression_to_string env inside indent indent_incr e in + let lv = typed_pattern_to_string env 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 = +and switch_to_string (env : fmt_env) (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 + let scrut = texpression_to_string env true indent1 indent_incr scrutinee in + let e_to_string = texpression_to_string env false indent1 indent_incr in match body with | If (e_true, e_false) -> let e_true = e_to_string e_true in @@ -778,79 +690,74 @@ and switch_to_string (fmt : ast_formatter) (indent : string) ^ 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 + let pat = typed_pattern_to_string env 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 loop_to_string (fmt : ast_formatter) (indent : string) - (indent_incr : string) (loop : loop) : string = +and loop_to_string (env : fmt_env) (indent : string) (indent_incr : string) + (loop : loop) : string = let indent1 = indent ^ indent_incr in let indent2 = indent1 ^ indent_incr in - let type_fmt = ast_to_type_formatter fmt in let loop_inputs = "fresh_vars: [" - ^ String.concat "; " (List.map (var_to_string type_fmt) loop.inputs) + ^ String.concat "; " (List.map (var_to_string env) loop.inputs) ^ "]" in let back_output_tys = let tys = match loop.back_output_tys with | None -> "" - | Some tys -> - String.concat "; " - (List.map (ty_to_string (ast_to_type_formatter fmt) false) tys) + | Some tys -> String.concat "; " (List.map (ty_to_string env false) tys) in "back_output_tys: [" ^ tys ^ "]" in let fun_end = - texpression_to_string fmt false indent2 indent_incr loop.fun_end + texpression_to_string env false indent2 indent_incr loop.fun_end in let loop_body = - texpression_to_string fmt false indent2 indent_incr loop.loop_body + texpression_to_string env false indent2 indent_incr loop.loop_body in "loop {\n" ^ indent1 ^ loop_inputs ^ "\n" ^ indent1 ^ back_output_tys ^ "\n" ^ indent1 ^ "fun_end: {\n" ^ indent2 ^ fun_end ^ "\n" ^ indent1 ^ "}\n" ^ indent1 ^ "loop_body: {\n" ^ indent2 ^ loop_body ^ "\n" ^ indent1 ^ "}\n" ^ indent ^ "}" -and meta_to_string (fmt : ast_formatter) (meta : meta) : string = +and meta_to_string (env : fmt_env) (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 ^ "]" + | Some rp -> " [@src=" ^ mplace_to_string env rp ^ "]" in - "@assign(" ^ mplace_to_string fmt lp ^ " := " - ^ texpression_to_string fmt false "" "" rv + "@assign(" ^ mplace_to_string env lp ^ " := " + ^ texpression_to_string env false "" "" rv ^ rp ^ ")" | SymbolicAssignment (var_id, rv) -> "@symb_assign(" ^ VarId.to_string var_id ^ " := " - ^ texpression_to_string fmt false "" "" rv + ^ texpression_to_string env false "" "" rv ^ ")" - | MPlace mp -> "@mplace=" ^ mplace_to_string fmt mp + | MPlace mp -> "@mplace=" ^ mplace_to_string env mp | Tag msg -> "@tag \"" ^ msg ^ "\"" 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.loop_id def.back_id - in - let signature = fun_sig_to_string fmt def.signature in +let fun_decl_to_string (env : fmt_env) (def : fun_decl) : string = + let env = { env with generics = def.signature.generics } in + let name = def.name ^ fun_suffix def.loop_id def.back_id in + let signature = fun_sig_to_string env 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 = List.map (var_to_string env) 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 body = texpression_to_string env inside indent indent body.body in "let " ^ name ^ " :\n " ^ signature ^ " =\n" ^ inputs ^ body diff --git a/compiler/Pure.ml b/compiler/Pure.ml index 72a6400e..fa059499 100644 --- a/compiler/Pure.ml +++ b/compiler/Pure.ml @@ -1,6 +1,4 @@ open Identifiers -open Names -module PV = PrimitiveValues module T = Types module V = Values module E = Expressions @@ -35,6 +33,7 @@ IdGen () module ConstGenericVarId = T.ConstGenericVarId +type llbc_name = T.name [@@deriving show, ord] type integer_type = T.integer_type [@@deriving show, ord] type const_generic_var = T.const_generic_var [@@deriving show, ord] type const_generic = T.const_generic [@@deriving show, ord] @@ -381,7 +380,13 @@ type predicates = { trait_type_constraints : trait_type_constraint list } type type_decl = { def_id : TypeDeclId.id; - name : name; + llbc_name : llbc_name; + (** The original name coming from the LLBC declaration *) + name : string; + (** We use the name only for printing purposes (for debugging): + the name used at extraction time will be derived from the + llbc_name. + *) generics : generic_params; kind : type_decl_kind; preds : predicates; @@ -994,11 +999,11 @@ type fun_decl = { loop_id : LoopId.id option; (** [Some] if this definition was generated for a loop *) 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. + llbc_name : llbc_name; (** The original LLBC name. *) + name : string; + (** We use the name only for printing purposes (for debugging): + the name used at extraction time will be derived from the + llbc_name. *) signature : fun_sig; is_global_decl_body : bool; @@ -1008,7 +1013,8 @@ type fun_decl = { type trait_decl = { def_id : trait_decl_id; - name : name; + llbc_name : llbc_name; + name : string; generics : generic_params; preds : predicates; parent_clauses : trait_clause list; @@ -1021,7 +1027,8 @@ type trait_decl = { type trait_impl = { def_id : trait_impl_id; - name : name; + llbc_name : llbc_name; + name : string; impl_trait : trait_decl_ref; generics : generic_params; preds : predicates; diff --git a/compiler/PureTypeCheck.ml b/compiler/PureTypeCheck.ml index ea1851f0..a62a2361 100644 --- a/compiler/PureTypeCheck.ml +++ b/compiler/PureTypeCheck.ml @@ -63,7 +63,7 @@ type tc_ctx = { let check_literal (v : literal) (ty : literal_type) : unit = match (ty, v) with - | TInteger int_ty, PV.VScalar sv -> assert (int_ty = sv.PV.int_ty) + | TInteger int_ty, VScalar sv -> assert (int_ty = sv.int_ty) | TBool, VBool _ | TChar, VChar _ -> () | _ -> raise (Failure "Inconsistent type") diff --git a/compiler/PureUtils.ml b/compiler/PureUtils.ml index 4cc7ef91..5f92d18a 100644 --- a/compiler/PureUtils.ml +++ b/compiler/PureUtils.ml @@ -15,11 +15,11 @@ end module RegularFunIdMap = Collections.MakeMap (RegularFunIdOrderedType) (** We use this type as a key for lookups *) -type regular_fun_id_not_loop = A.fun_id * T.RegionGroupId.id option +type regular_fun_id_not_loop = LlbcAst.fun_id * RegionGroupId.id option [@@deriving show, ord] (** We use this type as a key for lookups *) -type fun_loop_id = A.FunDeclId.id * LoopId.id option [@@deriving show, ord] +type fun_loop_id = FunDeclId.id * LoopId.id option [@@deriving show, ord] module RegularFunIdNotLoopOrderedType = struct type t = regular_fun_id_not_loop @@ -64,7 +64,7 @@ let dest_arrow_ty (ty : ty) : ty * ty = let compute_literal_type (cv : literal) : literal_type = match cv with - | PV.VScalar sv -> TInteger sv.PV.int_ty + | VScalar sv -> TInteger sv.int_ty | VBool _ -> TBool | VChar _ -> TChar @@ -647,6 +647,7 @@ let trait_decl_is_empty (trait_decl : trait_decl) : bool = let { def_id = _; name = _; + llbc_name = _; generics = _; preds = _; parent_clauses; @@ -664,6 +665,7 @@ let trait_impl_is_empty (trait_impl : trait_impl) : bool = let { def_id = _; name = _; + llbc_name = _; impl_trait = _; generics = _; preds = _; diff --git a/compiler/RegionsHierarchy.ml b/compiler/RegionsHierarchy.ml index 8227e1fa..e101ba49 100644 --- a/compiler/RegionsHierarchy.ml +++ b/compiler/RegionsHierarchy.ml @@ -25,7 +25,6 @@ be grouped together). *) -open Names open Types open TypesUtils open Expressions @@ -42,9 +41,9 @@ let compute_regions_hierarchy_for_sig (type_decls : type_decl TypeDeclId.Map.t) (fun_decls : fun_decl FunDeclId.Map.t) (global_decls : global_decl GlobalDeclId.Map.t) (trait_decls : trait_decl TraitDeclId.Map.t) - (trait_impls : trait_impl TraitImplId.Map.t) (fun_name : name) + (trait_impls : trait_impl TraitImplId.Map.t) (fun_name : string) (sg : fun_sig) : region_groups = - log#ldebug (lazy (__FUNCTION__ ^ ": " ^ name_to_string fun_name)); + log#ldebug (lazy (__FUNCTION__ ^ ": " ^ fun_name)); (* Initialize a normalization context (we may need to normalize some associated types) *) let norm_ctx : AssociatedTypes.norm_ctx = @@ -264,10 +263,23 @@ let compute_regions_hierarchies (type_decls : type_decl TypeDeclId.Map.t) (global_decls : global_decl GlobalDeclId.Map.t) (trait_decls : trait_decl TraitDeclId.Map.t) (trait_impls : trait_impl TraitImplId.Map.t) : region_groups FunIdMap.t = + let open Print in + let env : fmt_env = + { + type_decls; + fun_decls; + global_decls; + trait_decls; + trait_impls; + generics = empty_generic_params; + preds = empty_predicates; + locals = []; + } + in let regular = List.map (fun ((fid, d) : FunDeclId.id * fun_decl) -> - (FRegular fid, (d.name, d.signature))) + (FRegular fid, (Types.name_to_string env d.name, d.signature))) (FunDeclId.Map.bindings fun_decls) in let assumed = diff --git a/compiler/Substitute.ml b/compiler/Substitute.ml index 45edc602..01509dec 100644 --- a/compiler/Substitute.ml +++ b/compiler/Substitute.ml @@ -2,26 +2,26 @@ function bodies, etc. *) -module T = Types -module TU = TypesUtils -module V = Values -module E = Expressions -module A = LlbcAst -module C = Contexts +open Types +open TypesUtils +open Values +open Expressions +open LlbcAst +open Contexts type subst = { - r_subst : T.region -> T.region; - ty_subst : T.TypeVarId.id -> T.ty; - cg_subst : T.ConstGenericVarId.id -> T.const_generic; + r_subst : region -> region; + ty_subst : TypeVarId.id -> ty; + cg_subst : ConstGenericVarId.id -> const_generic; (** Substitution from *local* trait clause to trait instance *) - tr_subst : T.TraitClauseId.id -> T.trait_instance_id; + tr_subst : TraitClauseId.id -> trait_instance_id; (** Substitution for the [Self] trait instance *) - tr_self : T.trait_instance_id; + tr_self : trait_instance_id; } let st_substitute_visitor (subst : subst) = object - inherit [_] A.map_statement + inherit [_] map_statement method! visit_region _ r = subst.r_subst r method! visit_TVar _ id = subst.ty_subst id @@ -43,51 +43,50 @@ let st_substitute_visitor (subst : subst) = **IMPORTANT**: this doesn't normalize the types. *) -let ty_substitute (subst : subst) (ty : T.ty) : T.ty = +let ty_substitute (subst : subst) (ty : ty) : ty = let visitor = st_substitute_visitor subst in visitor#visit_ty () ty (** **IMPORTANT**: this doesn't normalize the types. *) -let trait_ref_substitute (subst : subst) (tr : T.trait_ref) : T.trait_ref = +let trait_ref_substitute (subst : subst) (tr : trait_ref) : trait_ref = let visitor = st_substitute_visitor subst in visitor#visit_trait_ref () tr (** **IMPORTANT**: this doesn't normalize the types. *) -let trait_instance_id_substitute (subst : subst) (tr : T.trait_instance_id) : - T.trait_instance_id = +let trait_instance_id_substitute (subst : subst) (tr : trait_instance_id) : + trait_instance_id = let visitor = st_substitute_visitor subst in visitor#visit_trait_instance_id () tr (** **IMPORTANT**: this doesn't normalize the types. *) -let generic_args_substitute (subst : subst) (g : T.generic_args) : - T.generic_args = +let generic_args_substitute (subst : subst) (g : generic_args) : generic_args = let visitor = st_substitute_visitor subst in visitor#visit_generic_args () g -let predicates_substitute (subst : subst) (p : T.predicates) : T.predicates = +let predicates_substitute (subst : subst) (p : predicates) : predicates = let visitor = st_substitute_visitor subst in visitor#visit_predicates () p let erase_regions_subst : subst = { - r_subst = (fun _ -> T.RErased); - ty_subst = (fun vid -> T.TVar vid); - cg_subst = (fun id -> T.CGVar id); - tr_subst = (fun id -> T.Clause id); - tr_self = T.Self; + r_subst = (fun _ -> RErased); + ty_subst = (fun vid -> TVar vid); + cg_subst = (fun id -> CGVar id); + tr_subst = (fun id -> Clause id); + tr_self = Self; } -(** Convert an {!T.rty} to an {!T.ety} by erasing the region variables *) -let erase_regions (ty : T.ty) : T.ty = ty_substitute erase_regions_subst ty +(** Convert an {!rty} to an {!ety} by erasing the region variables *) +let erase_regions (ty : ty) : ty = ty_substitute erase_regions_subst ty -let trait_ref_erase_regions (tr : T.trait_ref) : T.trait_ref = +let trait_ref_erase_regions (tr : trait_ref) : trait_ref = trait_ref_substitute erase_regions_subst tr -let trait_instance_id_erase_regions (tr : T.trait_instance_id) : - T.trait_instance_id = +let trait_instance_id_erase_regions (tr : trait_instance_id) : trait_instance_id + = trait_instance_id_substitute erase_regions_subst tr -let generic_args_erase_regions (tr : T.generic_args) : T.generic_args = +let generic_args_erase_regions (tr : generic_args) : generic_args = generic_args_substitute erase_regions_subst tr (** Generate fresh regions for region variables. @@ -95,133 +94,124 @@ let generic_args_erase_regions (tr : T.generic_args) : T.generic_args = 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] + TODO: simplify? we only need the subst [RegionVarId.id -> RegionId.id] *) -let fresh_regions_with_substs (region_vars : T.region_var list) : - T.RegionId.id list - * (T.RegionId.id -> T.RegionId.id) - * (T.region -> T.region) = +let fresh_regions_with_substs (region_vars : region_var list) : + RegionId.id list * (RegionId.id -> RegionId.id) * (region -> region) = (* Generate fresh regions *) - let fresh_region_ids = List.map (fun _ -> C.fresh_region_id ()) region_vars in + let fresh_region_ids = List.map (fun _ -> 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 : T.region_var), v) -> T.RegionId.Map.add k.T.index v mp) - T.RegionId.Map.empty ls + (fun mp ((k : region_var), v) -> RegionId.Map.add k.index v mp) + RegionId.Map.empty ls in (* Generate the substitution from region var id to region *) - let rid_subst id = T.RegionId.Map.find id rid_map in + let rid_subst id = RegionId.Map.find id rid_map in (* Generate the substitution from region to region *) - let r_subst (r : T.region) = - match r with - | T.RStatic | T.RErased -> r - | T.RVar id -> T.RVar (rid_subst id) + let r_subst (r : region) = + match r with RStatic | RErased -> r | RVar id -> RVar (rid_subst id) in (* Return *) (fresh_region_ids, rid_subst, r_subst) (** Erase the regions in a type and perform a substitution *) -let erase_regions_substitute_types (ty_subst : T.TypeVarId.id -> T.ty) - (cg_subst : T.ConstGenericVarId.id -> T.const_generic) - (tr_subst : T.TraitClauseId.id -> T.trait_instance_id) - (tr_self : T.trait_instance_id) (ty : T.ty) : T.ty = - let r_subst (_ : T.region) : T.region = T.RErased in +let erase_regions_substitute_types (ty_subst : TypeVarId.id -> ty) + (cg_subst : ConstGenericVarId.id -> const_generic) + (tr_subst : TraitClauseId.id -> trait_instance_id) + (tr_self : trait_instance_id) (ty : ty) : ty = + let r_subst (_ : region) : region = RErased in let subst = { r_subst; ty_subst; cg_subst; tr_subst; tr_self } in ty_substitute subst 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.RegionId.id list) (regions : T.region list) : - T.region -> T.region = +let make_region_subst (var_ids : RegionId.id list) (regions : region list) : + region -> region = let ls = List.combine var_ids regions in let mp = List.fold_left - (fun mp (k, v) -> T.RegionId.Map.add k v mp) - T.RegionId.Map.empty ls + (fun mp (k, v) -> RegionId.Map.add k v mp) + RegionId.Map.empty ls in fun r -> - match r with - | T.RStatic | T.RErased -> r - | T.RVar id -> T.RegionId.Map.find id mp + match r with RStatic | RErased -> r | RVar id -> RegionId.Map.find id mp -let make_region_subst_from_vars (vars : T.region_var list) - (regions : T.region list) : T.region -> T.region = - make_region_subst - (List.map (fun (x : T.region_var) -> x.T.index) vars) - regions +let make_region_subst_from_vars (vars : region_var list) (regions : region list) + : region -> region = + make_region_subst (List.map (fun (x : region_var) -> x.index) vars) regions (** 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 : T.ty list) : - T.TypeVarId.id -> T.ty = +let make_type_subst (var_ids : TypeVarId.id list) (tys : ty list) : + TypeVarId.id -> 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 + (fun mp (k, v) -> TypeVarId.Map.add k v mp) + TypeVarId.Map.empty ls in - fun id -> T.TypeVarId.Map.find id mp + fun id -> TypeVarId.Map.find id mp -let make_type_subst_from_vars (vars : T.type_var list) (tys : T.ty list) : - T.TypeVarId.id -> T.ty = - make_type_subst (List.map (fun (x : T.type_var) -> x.T.index) vars) tys +let make_type_subst_from_vars (vars : type_var list) (tys : ty list) : + TypeVarId.id -> ty = + make_type_subst (List.map (fun (x : type_var) -> x.index) vars) tys (** Create a const generic substitution from a list of const generic variable ids and a list of const generics (with which to substitute the const generic variable ids) *) -let make_const_generic_subst (var_ids : T.ConstGenericVarId.id list) - (cgs : T.const_generic list) : T.ConstGenericVarId.id -> T.const_generic = +let make_const_generic_subst (var_ids : ConstGenericVarId.id list) + (cgs : const_generic list) : ConstGenericVarId.id -> const_generic = let ls = List.combine var_ids cgs in let mp = List.fold_left - (fun mp (k, v) -> T.ConstGenericVarId.Map.add k v mp) - T.ConstGenericVarId.Map.empty ls + (fun mp (k, v) -> ConstGenericVarId.Map.add k v mp) + ConstGenericVarId.Map.empty ls in - fun id -> T.ConstGenericVarId.Map.find id mp + fun id -> ConstGenericVarId.Map.find id mp -let make_const_generic_subst_from_vars (vars : T.const_generic_var list) - (cgs : T.const_generic list) : T.ConstGenericVarId.id -> T.const_generic = +let make_const_generic_subst_from_vars (vars : const_generic_var list) + (cgs : const_generic list) : ConstGenericVarId.id -> const_generic = make_const_generic_subst - (List.map (fun (x : T.const_generic_var) -> x.T.index) vars) + (List.map (fun (x : const_generic_var) -> x.index) vars) cgs (** Create a trait substitution from a list of trait clause ids and a list of trait refs *) -let make_trait_subst (clause_ids : T.TraitClauseId.id list) - (trs : T.trait_ref list) : T.TraitClauseId.id -> T.trait_instance_id = +let make_trait_subst (clause_ids : TraitClauseId.id list) (trs : trait_ref list) + : TraitClauseId.id -> trait_instance_id = let ls = List.combine clause_ids trs in let mp = List.fold_left - (fun mp (k, v) -> T.TraitClauseId.Map.add k (T.TraitRef v) mp) - T.TraitClauseId.Map.empty ls + (fun mp (k, v) -> TraitClauseId.Map.add k (TraitRef v) mp) + TraitClauseId.Map.empty ls in - fun id -> T.TraitClauseId.Map.find id mp + fun id -> TraitClauseId.Map.find id mp -let make_trait_subst_from_clauses (clauses : T.trait_clause list) - (trs : T.trait_ref list) : T.TraitClauseId.id -> T.trait_instance_id = +let make_trait_subst_from_clauses (clauses : trait_clause list) + (trs : trait_ref list) : TraitClauseId.id -> trait_instance_id = make_trait_subst - (List.map (fun (x : T.trait_clause) -> x.T.clause_id) clauses) + (List.map (fun (x : trait_clause) -> x.clause_id) clauses) trs -let make_subst_from_generics (params : T.generic_params) (args : T.generic_args) - (tr_self : T.trait_instance_id) : subst = - let r_subst = make_region_subst_from_vars params.T.regions args.T.regions in - let ty_subst = make_type_subst_from_vars params.T.types args.T.types in +let make_subst_from_generics (params : generic_params) (args : generic_args) + (tr_self : trait_instance_id) : subst = + let r_subst = make_region_subst_from_vars params.regions args.regions in + let ty_subst = make_type_subst_from_vars params.types args.types in let cg_subst = - make_const_generic_subst_from_vars params.T.const_generics - args.T.const_generics + make_const_generic_subst_from_vars params.const_generics args.const_generics in let tr_subst = - make_trait_subst_from_clauses params.T.trait_clauses args.T.trait_refs + make_trait_subst_from_clauses params.trait_clauses args.trait_refs in { r_subst; ty_subst; cg_subst; tr_subst; tr_self } -let make_subst_from_generics_erase_regions (params : T.generic_params) - (generics : T.generic_args) (tr_self : T.trait_instance_id) = +let make_subst_from_generics_erase_regions (params : generic_params) + (generics : generic_args) (tr_self : trait_instance_id) = let generics = generic_args_erase_regions generics in let tr_self = trait_instance_id_erase_regions tr_self in let subst = make_subst_from_generics params generics tr_self in - { subst with r_subst = (fun _ -> T.RErased) } + { subst with r_subst = (fun _ -> RErased) } (** Instantiate the type variables in an ADT definition, and return, for every variant, the list of the types of its fields. @@ -229,27 +219,25 @@ let make_subst_from_generics_erase_regions (params : T.generic_params) **IMPORTANT**: this function doesn't normalize the types, you may want to use the [AssociatedTypes] equivalent instead. *) -let type_decl_get_instantiated_variants_fields_types (def : T.type_decl) - (generics : T.generic_args) : (T.VariantId.id option * T.ty list) list = +let type_decl_get_instantiated_variants_fields_types (def : type_decl) + (generics : generic_args) : (VariantId.id option * ty list) list = (* There shouldn't be any reference to Self *) - let tr_self = T.UnknownTrait __FUNCTION__ in - let subst = make_subst_from_generics def.T.generics generics tr_self 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 -> + let tr_self = UnknownTrait __FUNCTION__ in + let subst = make_subst_from_generics def.generics generics tr_self in + let (variants_fields : (VariantId.id option * field list) list) = + match def.kind with + | Enum variants -> + List.mapi (fun i v -> (Some (VariantId.of_int i), v.fields)) variants + | Struct fields -> [ (None, fields) ] + | Opaque -> raise (Failure ("Can't retrieve the variants of an opaque type: " - ^ Names.name_to_string def.name)) + ^ show_name def.name)) in List.map (fun (id, fields) -> - (id, List.map (fun f -> ty_substitute subst f.T.field_ty) fields)) + (id, List.map (fun f -> ty_substitute subst f.field_ty) fields)) variants_fields (** Instantiate the type variables in an ADT definition, and return the list @@ -258,17 +246,16 @@ let type_decl_get_instantiated_variants_fields_types (def : T.type_decl) **IMPORTANT**: this function doesn't normalize the types, you may want to use the [AssociatedTypes] equivalent instead. *) -let type_decl_get_instantiated_field_types (def : T.type_decl) - (opt_variant_id : T.VariantId.id option) (generics : T.generic_args) : - T.ty list = +let type_decl_get_instantiated_field_types (def : type_decl) + (opt_variant_id : VariantId.id option) (generics : generic_args) : ty list = (* For now, check that there are no clauses - otherwise we might need to normalize the types *) assert (def.generics.trait_clauses = []); (* There shouldn't be any reference to Self *) - let tr_self = T.UnknownTrait __FUNCTION__ in - let subst = make_subst_from_generics def.T.generics generics tr_self in - let fields = TU.type_decl_get_fields def opt_variant_id in - List.map (fun f -> ty_substitute subst f.T.field_ty) fields + let tr_self = UnknownTrait __FUNCTION__ in + let subst = make_subst_from_generics def.generics generics tr_self in + let fields = type_decl_get_fields def opt_variant_id in + List.map (fun f -> ty_substitute subst f.field_ty) fields (** Return the types of the properly instantiated ADT's variant, provided a context. @@ -276,10 +263,10 @@ let type_decl_get_instantiated_field_types (def : T.type_decl) **IMPORTANT**: this function doesn't normalize the types, you may want to use the [AssociatedTypes] equivalent instead. *) -let ctx_adt_get_instantiated_field_types (ctx : C.eval_ctx) - (def_id : T.TypeDeclId.id) (opt_variant_id : T.VariantId.id option) - (generics : T.generic_args) : T.ty list = - let def = C.ctx_lookup_type_decl ctx def_id in +let ctx_adt_get_instantiated_field_types (ctx : eval_ctx) + (def_id : TypeDeclId.id) (opt_variant_id : VariantId.id option) + (generics : generic_args) : ty list = + let def = ctx_lookup_type_decl ctx def_id in type_decl_get_instantiated_field_types def opt_variant_id generics (** Return the types of the properly instantiated ADT value (note that @@ -288,98 +275,94 @@ let ctx_adt_get_instantiated_field_types (ctx : C.eval_ctx) **IMPORTANT**: this function doesn't normalize the types, you may want to use the [AssociatedTypes] equivalent instead. *) -let ctx_adt_value_get_instantiated_field_types (ctx : C.eval_ctx) - (adt : V.adt_value) (id : T.type_id) (generics : T.generic_args) : T.ty list - = +let ctx_adt_value_get_instantiated_field_types (ctx : eval_ctx) + (adt : adt_value) (id : type_id) (generics : generic_args) : ty list = match id with - | T.TAdtId id -> + | TAdtId id -> (* Retrieve the types of the fields *) - ctx_adt_get_instantiated_field_types ctx id adt.V.variant_id generics - | T.TTuple -> + ctx_adt_get_instantiated_field_types ctx id adt.variant_id generics + | TTuple -> assert (generics.regions = []); generics.types - | T.TAssumed aty -> ( + | TAssumed aty -> ( match aty with - | T.TBox -> + | TBox -> assert (generics.regions = []); assert (List.length generics.types = 1); assert (generics.const_generics = []); generics.types - | T.TArray | T.TSlice | T.TStr -> + | TArray | TSlice | TStr -> (* Those types don't have fields *) raise (Failure "Unreachable")) (** Apply a type substitution to a place *) -let place_substitute (subst : subst) (p : E.place) : E.place = +let place_substitute (subst : subst) (p : place) : place = (* There is in fact nothing to do *) (st_substitute_visitor subst)#visit_place () p (** Apply a type substitution to an operand *) -let operand_substitute (subst : subst) (op : E.operand) : E.operand = +let operand_substitute (subst : subst) (op : operand) : operand = (st_substitute_visitor subst)#visit_operand () op (** Apply a type substitution to an rvalue *) -let rvalue_substitute (subst : subst) (rv : E.rvalue) : E.rvalue = +let rvalue_substitute (subst : subst) (rv : rvalue) : rvalue = (st_substitute_visitor subst)#visit_rvalue () rv (** Apply a type substitution to an assertion *) -let assertion_substitute (subst : subst) (a : A.assertion) : A.assertion = +let assertion_substitute (subst : subst) (a : assertion) : assertion = (st_substitute_visitor subst)#visit_assertion () a (** Apply a type substitution to a call *) -let call_substitute (subst : subst) (call : A.call) : A.call = +let call_substitute (subst : subst) (call : call) : call = (st_substitute_visitor subst)#visit_call () call (** Apply a type substitution to a statement *) -let statement_substitute (subst : subst) (st : A.statement) : A.statement = +let statement_substitute (subst : subst) (st : statement) : statement = (st_substitute_visitor subst)#visit_statement () st (** Apply a type substitution to a function body. Return the local variables and the body. *) -let fun_body_substitute_in_body (subst : subst) (body : A.fun_body) : - A.var list * A.statement = +let fun_body_substitute_in_body (subst : subst) (body : fun_body) : + var list * statement = let locals = List.map - (fun (v : A.var) -> { v with A.var_ty = ty_substitute subst v.A.var_ty }) - body.A.locals + (fun (v : var) -> { v with var_ty = ty_substitute subst v.var_ty }) + body.locals in let body = statement_substitute subst body.body in (locals, body) let trait_type_constraint_substitute (subst : subst) - (ttc : T.trait_type_constraint) : T.trait_type_constraint = - let { T.trait_ref; generics; type_name; ty } = ttc in + (ttc : trait_type_constraint) : trait_type_constraint = + let { trait_ref; generics; type_name; ty } = ttc in let visitor = st_substitute_visitor subst in let trait_ref = visitor#visit_trait_ref () trait_ref in let generics = visitor#visit_generic_args () generics in let ty = visitor#visit_ty () ty in - { T.trait_ref; generics; type_name; ty } + { trait_ref; generics; type_name; ty } (** Substitute a function signature, together with the regions hierarchy associated to that signature. **IMPORTANT:** this function doesn't normalize the types. *) -let substitute_signature (asubst : T.RegionGroupId.id -> V.AbstractionId.id) - (r_subst : T.RegionId.id -> T.RegionId.id) - (ty_subst : T.TypeVarId.id -> T.ty) - (cg_subst : T.ConstGenericVarId.id -> T.const_generic) - (tr_subst : T.TraitClauseId.id -> T.trait_instance_id) - (tr_self : T.trait_instance_id) (sg : A.fun_sig) - (regions_hierarchy : T.region_groups) : A.inst_fun_sig = - let r_subst' (r : T.region) : T.region = - match r with - | T.RStatic | T.RErased -> r - | T.RVar rid -> T.RVar (r_subst rid) +let substitute_signature (asubst : RegionGroupId.id -> AbstractionId.id) + (r_subst : RegionId.id -> RegionId.id) (ty_subst : TypeVarId.id -> ty) + (cg_subst : ConstGenericVarId.id -> const_generic) + (tr_subst : TraitClauseId.id -> trait_instance_id) + (tr_self : trait_instance_id) (sg : fun_sig) + (regions_hierarchy : region_groups) : inst_fun_sig = + let r_subst' (r : region) : region = + match r with RStatic | RErased -> r | RVar rid -> RVar (r_subst rid) in let subst = { r_subst = r_subst'; ty_subst; cg_subst; tr_subst; tr_self } in - let inputs = List.map (ty_substitute subst) sg.A.inputs in - let output = ty_substitute subst sg.A.output in - let subst_region_group (rg : T.region_group) : A.abs_region_group = + let inputs = List.map (ty_substitute subst) sg.inputs in + let output = ty_substitute subst sg.output in + let subst_region_group (rg : region_group) : abs_region_group = let id = asubst rg.id in let regions = List.map r_subst rg.regions in let parents = List.map asubst rg.parents in - ({ id; regions; parents } : A.abs_region_group) + ({ id; regions; parents } : abs_region_group) in let regions_hierarchy = List.map subst_region_group regions_hierarchy in let trait_type_constraints = @@ -387,13 +370,11 @@ let substitute_signature (asubst : T.RegionGroupId.id -> V.AbstractionId.id) (trait_type_constraint_substitute subst) sg.preds.trait_type_constraints in - { A.inputs; output; regions_hierarchy; trait_type_constraints } + { inputs; output; regions_hierarchy; trait_type_constraints } (** Substitute variable identifiers in a type *) -let statement_substitute_ids (ty_subst : T.TypeVarId.id -> T.TypeVarId.id) - (cg_subst : T.ConstGenericVarId.id -> T.ConstGenericVarId.id) (ty : T.ty) : - T.ty = - let open T in +let statement_substitute_ids (ty_subst : TypeVarId.id -> TypeVarId.id) + (cg_subst : ConstGenericVarId.id -> ConstGenericVarId.id) (ty : ty) : ty = let visitor = object inherit [_] map_ty @@ -405,14 +386,14 @@ let statement_substitute_ids (ty_subst : T.TypeVarId.id -> T.TypeVarId.id) visitor#visit_ty () ty -let subst_ids_visitor (r_subst : T.RegionId.id -> T.RegionId.id) - (ty_subst : T.TypeVarId.id -> T.TypeVarId.id) - (cg_subst : T.ConstGenericVarId.id -> T.ConstGenericVarId.id) - (ssubst : V.SymbolicValueId.id -> V.SymbolicValueId.id) - (bsubst : V.BorrowId.id -> V.BorrowId.id) - (asubst : V.AbstractionId.id -> V.AbstractionId.id) = +let subst_ids_visitor (r_subst : RegionId.id -> RegionId.id) + (ty_subst : TypeVarId.id -> TypeVarId.id) + (cg_subst : ConstGenericVarId.id -> ConstGenericVarId.id) + (ssubst : SymbolicValueId.id -> SymbolicValueId.id) + (bsubst : BorrowId.id -> BorrowId.id) + (asubst : AbstractionId.id -> AbstractionId.id) = object (self : 'self) - inherit [_] C.map_env + inherit [_] map_env method! visit_type_var_id _ id = ty_subst id method! visit_const_generic_var_id _ id = cg_subst id method! visit_region_id _ rid = r_subst rid @@ -429,18 +410,17 @@ let subst_ids_visitor (r_subst : T.RegionId.id -> T.RegionId.id) method! visit_abstraction_id _ id = asubst id end -let typed_value_subst_ids (r_subst : T.RegionId.id -> T.RegionId.id) - (ty_subst : T.TypeVarId.id -> T.TypeVarId.id) - (cg_subst : T.ConstGenericVarId.id -> T.ConstGenericVarId.id) - (ssubst : V.SymbolicValueId.id -> V.SymbolicValueId.id) - (bsubst : V.BorrowId.id -> V.BorrowId.id) (v : V.typed_value) : - V.typed_value = +let typed_value_subst_ids (r_subst : RegionId.id -> RegionId.id) + (ty_subst : TypeVarId.id -> TypeVarId.id) + (cg_subst : ConstGenericVarId.id -> ConstGenericVarId.id) + (ssubst : SymbolicValueId.id -> SymbolicValueId.id) + (bsubst : BorrowId.id -> BorrowId.id) (v : typed_value) : typed_value = let asubst _ = raise (Failure "Unreachable") in let vis = subst_ids_visitor r_subst ty_subst cg_subst ssubst bsubst asubst in vis#visit_typed_value () v -let typed_value_subst_rids (r_subst : T.RegionId.id -> T.RegionId.id) - (v : V.typed_value) : V.typed_value = +let typed_value_subst_rids (r_subst : RegionId.id -> RegionId.id) + (v : typed_value) : typed_value = typed_value_subst_ids r_subst (fun x -> x) (fun x -> x) @@ -448,36 +428,35 @@ let typed_value_subst_rids (r_subst : T.RegionId.id -> T.RegionId.id) (fun x -> x) v -let typed_avalue_subst_ids (r_subst : T.RegionId.id -> T.RegionId.id) - (ty_subst : T.TypeVarId.id -> T.TypeVarId.id) - (cg_subst : T.ConstGenericVarId.id -> T.ConstGenericVarId.id) - (ssubst : V.SymbolicValueId.id -> V.SymbolicValueId.id) - (bsubst : V.BorrowId.id -> V.BorrowId.id) (v : V.typed_avalue) : - V.typed_avalue = +let typed_avalue_subst_ids (r_subst : RegionId.id -> RegionId.id) + (ty_subst : TypeVarId.id -> TypeVarId.id) + (cg_subst : ConstGenericVarId.id -> ConstGenericVarId.id) + (ssubst : SymbolicValueId.id -> SymbolicValueId.id) + (bsubst : BorrowId.id -> BorrowId.id) (v : typed_avalue) : typed_avalue = let asubst _ = raise (Failure "Unreachable") in let vis = subst_ids_visitor r_subst ty_subst cg_subst ssubst bsubst asubst in vis#visit_typed_avalue () v -let abs_subst_ids (r_subst : T.RegionId.id -> T.RegionId.id) - (ty_subst : T.TypeVarId.id -> T.TypeVarId.id) - (cg_subst : T.ConstGenericVarId.id -> T.ConstGenericVarId.id) - (ssubst : V.SymbolicValueId.id -> V.SymbolicValueId.id) - (bsubst : V.BorrowId.id -> V.BorrowId.id) - (asubst : V.AbstractionId.id -> V.AbstractionId.id) (x : V.abs) : V.abs = +let abs_subst_ids (r_subst : RegionId.id -> RegionId.id) + (ty_subst : TypeVarId.id -> TypeVarId.id) + (cg_subst : ConstGenericVarId.id -> ConstGenericVarId.id) + (ssubst : SymbolicValueId.id -> SymbolicValueId.id) + (bsubst : BorrowId.id -> BorrowId.id) + (asubst : AbstractionId.id -> AbstractionId.id) (x : abs) : abs = let vis = subst_ids_visitor r_subst ty_subst cg_subst ssubst bsubst asubst in vis#visit_abs () x -let env_subst_ids (r_subst : T.RegionId.id -> T.RegionId.id) - (ty_subst : T.TypeVarId.id -> T.TypeVarId.id) - (cg_subst : T.ConstGenericVarId.id -> T.ConstGenericVarId.id) - (ssubst : V.SymbolicValueId.id -> V.SymbolicValueId.id) - (bsubst : V.BorrowId.id -> V.BorrowId.id) - (asubst : V.AbstractionId.id -> V.AbstractionId.id) (x : C.env) : C.env = +let env_subst_ids (r_subst : RegionId.id -> RegionId.id) + (ty_subst : TypeVarId.id -> TypeVarId.id) + (cg_subst : ConstGenericVarId.id -> ConstGenericVarId.id) + (ssubst : SymbolicValueId.id -> SymbolicValueId.id) + (bsubst : BorrowId.id -> BorrowId.id) + (asubst : AbstractionId.id -> AbstractionId.id) (x : env) : env = let vis = subst_ids_visitor r_subst ty_subst cg_subst ssubst bsubst asubst in vis#visit_env () x -let typed_avalue_subst_rids (r_subst : T.RegionId.id -> T.RegionId.id) - (x : V.typed_avalue) : V.typed_avalue = +let typed_avalue_subst_rids (r_subst : RegionId.id -> RegionId.id) + (x : typed_avalue) : typed_avalue = let asubst _ = raise (Failure "Unreachable") in let vis = subst_ids_visitor r_subst @@ -489,8 +468,7 @@ let typed_avalue_subst_rids (r_subst : T.RegionId.id -> T.RegionId.id) in vis#visit_typed_avalue () x -let env_subst_rids (r_subst : T.RegionId.id -> T.RegionId.id) (x : C.env) : - C.env = +let env_subst_rids (r_subst : RegionId.id -> RegionId.id) (x : env) : env = let vis = subst_ids_visitor r_subst (fun x -> x) diff --git a/compiler/SymbolicAst.ml b/compiler/SymbolicAst.ml index d114f18d..7c5d28a7 100644 --- a/compiler/SymbolicAst.ml +++ b/compiler/SymbolicAst.ml @@ -3,10 +3,10 @@ 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 +open Types +open Expressions +open Values +open LlbcAst (** "Meta"-place: a place stored as meta-data. @@ -23,16 +23,16 @@ type mplace = { because the most important information in a place is the name of the variable! *) - projection : E.projection; + projection : projection; (** We store the projection because we can, but it is actually not that useful *) } [@@deriving show] type call_id = - | Fun of A.fun_id_or_trait_method_ref * V.FunCallId.id + | Fun of fun_id_or_trait_method_ref * FunCallId.id (** A "regular" function (i.e., a function which is not a primitive operation) *) - | Unop of E.unop - | Binop of E.binop + | Unop of unop + | Binop of binop [@@deriving show, ord] type call = { @@ -42,11 +42,11 @@ type call = { evaluated). We need it to compute the translated values for shared borrows (we need to perform lookups). *) - abstractions : V.AbstractionId.id list; - generics : T.generic_args; - args : V.typed_value list; + abstractions : AbstractionId.id list; + generics : generic_args; + args : typed_value list; args_places : mplace option list; (** Meta information *) - dest : V.symbolic_value; + dest : symbolic_value; dest_place : mplace option; (** Meta information *) } [@@deriving show] @@ -56,14 +56,14 @@ type call = { *) type meta = - | Assignment of Contexts.eval_ctx * mplace * V.typed_value * mplace option + | Assignment of Contexts.eval_ctx * mplace * typed_value * mplace option (** We generated an assignment (destination, assigned value, src) *) [@@deriving show] -type variant_id = T.VariantId.id [@@deriving show] -type global_decl_id = A.GlobalDeclId.id [@@deriving show] -type 'a symbolic_value_id_map = 'a V.SymbolicValueId.Map.t [@@deriving show] -type 'a region_group_id_map = 'a T.RegionGroupId.Map.t [@@deriving show] +type variant_id = VariantId.id [@@deriving show] +type global_decl_id = GlobalDeclId.id [@@deriving show] +type 'a symbolic_value_id_map = 'a SymbolicValueId.Map.t [@@deriving show] +type 'a region_group_id_map = 'a RegionGroupId.Map.t [@@deriving show] (** Ancestor for {!expression} iter visitor. @@ -73,12 +73,12 @@ type 'a region_group_id_map = 'a T.RegionGroupId.Map.t [@@deriving show] *) class ['self] iter_expression_base = object (self : 'self) - inherit [_] V.iter_abs + inherit [_] iter_abs method visit_eval_ctx : 'env -> Contexts.eval_ctx -> unit = fun _ _ -> () method visit_call : 'env -> call -> unit = fun _ _ -> () - method visit_loop_id : 'env -> V.loop_id -> unit = fun _ _ -> () + method visit_loop_id : 'env -> loop_id -> unit = fun _ _ -> () - method visit_region_group_id : 'env -> T.RegionGroupId.id -> unit = + method visit_region_group_id : 'env -> RegionGroupId.id -> unit = fun _ _ -> () method visit_mplace : 'env -> mplace -> unit = fun _ _ -> () @@ -87,7 +87,7 @@ class ['self] iter_expression_base = method visit_region_group_id_map : 'a. ('env -> 'a -> unit) -> 'env -> 'a region_group_id_map -> unit = fun f env m -> - T.RegionGroupId.Map.iter + RegionGroupId.Map.iter (fun id x -> self#visit_region_group_id env id; f env x) @@ -96,18 +96,16 @@ class ['self] iter_expression_base = method visit_symbolic_value_id_map : 'a. ('env -> 'a -> unit) -> 'env -> 'a symbolic_value_id_map -> unit = fun f env m -> - V.SymbolicValueId.Map.iter + SymbolicValueId.Map.iter (fun id x -> self#visit_symbolic_value_id env id; f env x) m - method visit_symbolic_value_id_set : 'env -> V.symbolic_value_id_set -> unit - = - fun env s -> - V.SymbolicValueId.Set.iter (self#visit_symbolic_value_id env) s + method visit_symbolic_value_id_set : 'env -> symbolic_value_id_set -> unit = + fun env s -> SymbolicValueId.Set.iter (self#visit_symbolic_value_id env) s - method visit_symbolic_expansion : 'env -> V.symbolic_expansion -> unit = + method visit_symbolic_expansion : 'env -> symbolic_expansion -> unit = fun _ _ -> () end @@ -116,7 +114,7 @@ class ['self] iter_expression_base = lambda-calculus expressions. *) type expression = - | Return of Contexts.eval_ctx * V.typed_value option + | Return of Contexts.eval_ctx * 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 @@ -128,22 +126,22 @@ type expression = *) | Panic | FunCall of call * expression - | EndAbstraction of Contexts.eval_ctx * V.abs * expression + | EndAbstraction of Contexts.eval_ctx * abs * expression (** The context is the evaluation context upon ending the abstraction, just after we removed the abstraction from the context. The context is the evaluation context from after evaluating the asserted value. It has the same purpose as for the {!Return} case. *) - | EvalGlobal of global_decl_id * V.symbolic_value * expression + | EvalGlobal of global_decl_id * symbolic_value * expression (** Evaluate a global to a fresh symbolic value *) - | Assertion of Contexts.eval_ctx * V.typed_value * expression + | Assertion of Contexts.eval_ctx * typed_value * expression (** An assertion. The context is the evaluation context from after evaluating the asserted value. It has the same purpose as for the {!Return} case. *) - | Expansion of mplace option * V.symbolic_value * expansion + | Expansion of mplace option * symbolic_value * expansion (** Expansion of a symbolic value. The place is "meta": it gives the path to the symbolic value (if available) @@ -155,7 +153,7 @@ type expression = | IntroSymbolic of Contexts.eval_ctx * mplace option - * V.symbolic_value + * symbolic_value * value_aggregate * expression (** We introduce a new symbolic value, equal to some other value. @@ -171,7 +169,7 @@ type expression = *) | ForwardEnd of Contexts.eval_ctx - * V.typed_value symbolic_value_id_map option + * typed_value symbolic_value_id_map option * expression * expression region_group_id_map (** We use this delimiter to indicate at which point we switch to the @@ -193,7 +191,7 @@ type expression = comments for the {!Return} variant). *) | Loop of loop (** Loop *) - | ReturnWithLoop of V.loop_id * bool + | ReturnWithLoop of loop_id * bool (** End the function with a call to a loop function. This encompasses the cases when we synthesize a function body @@ -205,12 +203,12 @@ type expression = | Meta of meta * expression (** Meta information *) and loop = { - loop_id : V.loop_id; - input_svalues : V.symbolic_value list; (** The input symbolic values *) - fresh_svalues : V.symbolic_value_id_set; + loop_id : loop_id; + input_svalues : symbolic_value list; (** The input symbolic values *) + fresh_svalues : symbolic_value_id_set; (** The symbolic values introduced by the loop fixed-point *) rg_to_given_back_tys : - ((T.RegionId.Set.t * T.ty list) T.RegionGroupId.Map.t[@opaque]); + ((RegionId.Set.t * ty list) RegionGroupId.Map.t[@opaque]); (** The map from region group ids to the types of the values given back by the corresponding loop abstractions. *) @@ -220,7 +218,7 @@ and loop = { } and expansion = - | ExpandNoBranch of V.symbolic_expansion * expression + | ExpandNoBranch of symbolic_expansion * expression (** A symbolic expansion which doesn't generate a branching. Includes: - concrete expansion @@ -228,25 +226,24 @@ and expansion = *Doesn't* include: - expansion of ADTs with one variant *) - | ExpandAdt of (variant_id option * V.symbolic_value list * expression) list + | ExpandAdt of (variant_id option * 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 + | ExpandInt of integer_type * (scalar_value * expression) list * expression (** An integer expansion (i.e, a switch over an integer). The last expression is for the "otherwise" branch. *) (* Remark: this type doesn't have to be mutually recursive with the other types, but it makes it easy to generate the visitors *) and value_aggregate = - | VaSingleValue of V.typed_value (** Regular case *) - | VaArray of V.typed_value list + | VaSingleValue of typed_value (** Regular case *) + | VaArray of typed_value list (** This is used when introducing array aggregates *) - | VaCGValue of T.const_generic_var_id + | VaCGValue of const_generic_var_id (** This is used when evaluating a const generic value: in the interpreter, we introduce a fresh symbolic value. *) - | VaTraitConstValue of T.trait_ref * T.generic_args * string + | VaTraitConstValue of trait_ref * generic_args * string (** A trait constant value *) [@@deriving show, diff --git a/compiler/SymbolicToPure.ml b/compiler/SymbolicToPure.ml index 922aa307..2460e040 100644 --- a/compiler/SymbolicToPure.ml +++ b/compiler/SymbolicToPure.ml @@ -2,18 +2,19 @@ open Utils open LlbcAstUtils open Pure open PureUtils +open PrimitiveValues +module T = Types module Id = Identifiers module C = Contexts module A = LlbcAst module S = SymbolicAst module TA = TypesAnalysis -module L = Logging module PP = PrintPure module FA = FunsAnalysis module IU = InterpreterUtils (** The local logger *) -let log = L.symbolic_to_pure_log +let log = Logging.symbolic_to_pure_log type type_context = { llbc_type_decls : T.type_decl TypeDeclId.Map.t; @@ -208,113 +209,92 @@ type bs_ctx = { [@@deriving show] (* TODO: move *) -let bs_ctx_to_ast_formatter (ctx : bs_ctx) : Print.Ast.ast_formatter = - Print.Ast.decls_and_fun_decl_to_ast_formatter ctx.type_context.llbc_type_decls - ctx.fun_context.llbc_fun_decls ctx.global_context.llbc_global_decls - ctx.trait_decls_ctx ctx.trait_impls_ctx ctx.fun_decl - -let bs_ctx_to_ctx_formatter (ctx : bs_ctx) : Print.Contexts.ctx_formatter = - let region_id_to_string = Print.Types.region_id_to_string in - let type_var_id_to_string = Print.Types.type_var_id_to_string in - let var_id_to_string = Print.Expressions.var_id_to_string in - let ast_fmt = bs_ctx_to_ast_formatter ctx in +let bs_ctx_to_fmt_env (ctx : bs_ctx) : Print.fmt_env = + 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 trait_decls = ctx.trait_decls_ctx in + let trait_impls = ctx.trait_impls_ctx in + let generics = ctx.fun_decl.signature.generics in + let preds = ctx.fun_decl.signature.preds in { - Print.Values.region_id_to_string; - type_var_id_to_string; - type_decl_id_to_string = ast_fmt.type_decl_id_to_string; - const_generic_var_id_to_string = ast_fmt.const_generic_var_id_to_string; - global_decl_id_to_string = ast_fmt.global_decl_id_to_string; - adt_variant_to_string = ast_fmt.adt_variant_to_string; - var_id_to_string; - adt_field_names = ast_fmt.adt_field_names; - trait_decl_id_to_string = ast_fmt.trait_decl_id_to_string; - trait_impl_id_to_string = ast_fmt.trait_impl_id_to_string; - trait_clause_id_to_string = ast_fmt.trait_clause_id_to_string; + type_decls; + fun_decls; + global_decls; + trait_decls; + trait_impls; + generics; + preds; + locals = []; } -let bs_ctx_to_pp_ast_formatter (ctx : bs_ctx) : PrintPure.ast_formatter = - let generics = ctx.fun_decl.signature.generics in +let bs_ctx_to_pure_fmt_env (ctx : bs_ctx) : PrintPure.fmt_env = 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 - ctx.trait_decls_ctx ctx.trait_impls_ctx generics.types - generics.const_generics + let trait_decls = ctx.trait_decls_ctx in + let trait_impls = ctx.trait_impls_ctx in + let generics = ctx.sg.generics in + { + type_decls; + fun_decls; + global_decls; + trait_decls; + trait_impls; + generics; + locals = []; + } let ctx_generic_args_to_string (ctx : bs_ctx) (args : T.generic_args) : string = - let fmt = bs_ctx_to_ctx_formatter ctx in - let fmt = Print.PC.ctx_to_type_formatter fmt in - Print.PT.generic_args_to_string fmt args + let env = bs_ctx_to_fmt_env ctx in + Print.Types.generic_args_to_string env args + +let name_to_string (ctx : bs_ctx) = + Print.Types.name_to_string (bs_ctx_to_fmt_env ctx) let symbolic_value_to_string (ctx : bs_ctx) (sv : V.symbolic_value) : string = - let fmt = bs_ctx_to_ctx_formatter ctx in - let fmt = Print.PC.ctx_to_type_formatter fmt in - Print.PV.symbolic_value_to_string fmt sv + let env = bs_ctx_to_fmt_env ctx in + Print.Values.symbolic_value_to_string env sv let typed_value_to_string (ctx : bs_ctx) (v : V.typed_value) : string = - let fmt = bs_ctx_to_ctx_formatter ctx in - Print.PV.typed_value_to_string fmt v + let env = bs_ctx_to_fmt_env ctx in + Print.Values.typed_value_to_string env v let pure_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 false ty + let env = bs_ctx_to_pure_fmt_env ctx in + PrintPure.ty_to_string env false ty let ty_to_string (ctx : bs_ctx) (ty : T.ty) : string = - let fmt = bs_ctx_to_ctx_formatter ctx in - let fmt = Print.PC.ctx_to_type_formatter fmt in - Print.PT.ty_to_string fmt ty + let env = bs_ctx_to_fmt_env ctx in + Print.Types.ty_to_string env ty let type_decl_to_string (ctx : bs_ctx) (def : type_decl) : string = - let type_decls = ctx.type_context.llbc_type_decls in - let global_decls = ctx.global_context.llbc_global_decls in - let fmt = - PrintPure.mk_type_formatter type_decls global_decls ctx.trait_decls_ctx - ctx.trait_impls_ctx def.generics.types def.generics.const_generics - in - PrintPure.type_decl_to_string fmt def + let env = bs_ctx_to_pure_fmt_env ctx in + PrintPure.type_decl_to_string env 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 env = bs_ctx_to_pure_fmt_env ctx in + PrintPure.texpression_to_string env false "" " " e let fun_sig_to_string (ctx : bs_ctx) (sg : fun_sig) : string = - let type_params = sg.generics.types in - let cg_params = sg.generics.const_generics 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 - ctx.trait_decls_ctx ctx.trait_impls_ctx type_params cg_params - in - PrintPure.fun_sig_to_string fmt sg + let env = bs_ctx_to_pure_fmt_env ctx in + PrintPure.fun_sig_to_string env sg let fun_decl_to_string (ctx : bs_ctx) (def : Pure.fun_decl) : string = - let generics = def.signature.generics in - let type_params = generics.types in - let cg_params = generics.const_generics 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 - ctx.trait_decls_ctx ctx.trait_impls_ctx type_params cg_params - in - PrintPure.fun_decl_to_string fmt def + let env = bs_ctx_to_pure_fmt_env ctx in + PrintPure.fun_decl_to_string env def let typed_pattern_to_string (ctx : bs_ctx) (p : Pure.typed_pattern) : string = - let fmt = bs_ctx_to_pp_ast_formatter ctx in - PrintPure.typed_pattern_to_string fmt p + let env = bs_ctx_to_pure_fmt_env ctx in + PrintPure.typed_pattern_to_string env p (* 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.Contexts.ast_to_value_formatter fmt in + let env = bs_ctx_to_fmt_env ctx in let verbose = false in let indent = "" in let indent_incr = " " in - Print.Values.abs_to_string fmt verbose indent indent_incr abs + Print.Values.abs_to_string env verbose indent indent_incr abs let get_instantiated_fun_sig (fun_id : A.fun_id) (back_id : T.RegionGroupId.id option) (generics : generic_args) @@ -421,7 +401,7 @@ let rec translate_sty (ty : T.ty) : ty = | TNever -> raise (Failure "Unreachable") | TRef (_, rty, _) -> translate rty | TRawPtr (ty, rkind) -> - let mut = match rkind with Mut -> Mut | Shared -> Const in + let mut = match rkind with RMut -> Mut | RShared -> Const in let ty = translate ty in let generics = { types = [ ty ]; const_generics = []; trait_refs = [] } in TAdt (TAssumed (TRawPtr mut), generics) @@ -481,21 +461,24 @@ let translate_variant (v : T.variant) : variant = let translate_variants (vl : T.variant list) : variant list = List.map translate_variant vl -(** Translate a type def kind to IM *) +(** Translate a type def kind from LLBC *) 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 +(** Translate a type definition from LLBC - TODO: this is not symbolic to pure but IM to pure. Still, I don't see the - point of moving this definition for now. + Remark: this is not symbolic to pure but LLBC 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 = +let translate_type_decl (ctx : Contexts.decls_ctx) (def : T.type_decl) : + type_decl = + let env = Print.Contexts.decls_ctx_to_fmt_env ctx in let def_id = def.T.def_id in - let name = def.name in + let llbc_name = def.name in + let name = Print.Types.name_to_string env def.name in let { T.regions; types; const_generics; trait_clauses } = def.generics in (* Can't translate types with regions for now *) assert (regions = []); @@ -503,7 +486,7 @@ let translate_type_decl (def : T.type_decl) : type_decl = let generics = { types; const_generics; trait_clauses } in let kind = translate_type_decl_kind def.T.kind in let preds = translate_predicates def.preds in - { def_id; name; generics; kind; preds } + { def_id; llbc_name; name; generics; kind; preds } let translate_type_id (id : T.type_id) : type_id = match id with @@ -564,7 +547,7 @@ let rec translate_fwd_ty (type_infos : TA.type_infos) (ty : T.ty) : ty = | TLiteral lty -> TLiteral lty | TRef (_, rty, _) -> translate rty | TRawPtr (ty, rkind) -> - let mut = match rkind with Mut -> Mut | Shared -> Const in + let mut = match rkind with RMut -> Mut | RShared -> Const in let ty = translate ty in let generics = { types = [ ty ]; const_generics = []; trait_refs = [] } in TAdt (TAssumed (TRawPtr mut), generics) @@ -655,10 +638,10 @@ let rec translate_back_ty (type_infos : TA.type_infos) | TLiteral lty -> wrap (TLiteral lty) | TRef (r, rty, rkind) -> ( match rkind with - | T.Shared -> + | RShared -> (* Ignore shared references, unless we are below a mutable borrow *) if inside_mut then translate rty else None - | T.Mut -> + | RMut -> (* Dive in, remembering the fact that we are inside a mutable borrow *) let inside_mut = true in if keep_region r then @@ -1034,7 +1017,7 @@ let translate_fun_sig (decls_ctx : C.decls_ctx) (fun_id : A.fun_id) effect_info; } in - let preds = translate_predicates sg.A.preds in + let preds = translate_predicates sg.preds in let sg = { generics; preds; inputs; output; doutputs; info } in { sg; output_names } @@ -1795,7 +1778,7 @@ and translate_end_abstraction_synth_input (ectx : C.eval_ctx) (abs : V.abs) log#ldebug (lazy ("translate_end_abstraction_synth_input:" ^ "\n- function: " - ^ Print.name_to_string ctx.fun_decl.name + ^ name_to_string ctx ctx.fun_decl.name ^ "\n- rg_id: " ^ T.RegionGroupId.to_string rg_id ^ "\n- loop_id: " @@ -2109,7 +2092,7 @@ and translate_end_abstraction_loop (ectx : C.eval_ctx) (abs : V.abs) (* Actually the same case as [SynthInput] *) translate_end_abstraction_synth_input ectx abs e ctx rg_id | V.LoopCall -> - let fun_id = E.FRegular ctx.fun_decl.A.def_id in + let fun_id = E.FRegular ctx.fun_decl.def_id in let effect_info = get_fun_effect_info ctx.fun_context.fun_infos (FunId fun_id) (Some vloop_id) (Some rg_id) @@ -2336,7 +2319,7 @@ and translate_expansion (p : S.mplace option) (sv : V.symbolic_value) (* We don't need to update the context: we don't introduce any * new values/variables *) let branch = translate_expression branch_e ctx in - let pat = mk_typed_pattern_from_literal (PV.VScalar v) in + let pat = mk_typed_pattern_from_literal (VScalar v) in { pat; branch } in let branches = List.map translate_branch branches in @@ -2569,7 +2552,7 @@ and translate_forward_end (ectx : C.eval_ctx) let org_args = args in (* Lookup the effect info for the loop function *) - let fid = E.FRegular ctx.fun_decl.A.def_id in + let fid = E.FRegular ctx.fun_decl.def_id in let effect_info = get_fun_effect_info ctx.fun_context.fun_infos (FunId fid) None ctx.bid in @@ -2918,14 +2901,15 @@ let translate_fun_decl (ctx : bs_ctx) (body : S.expression option) : fun_decl = log#ldebug (lazy ("SymbolicToPure.translate_fun_decl: " - ^ Print.fun_name_to_string def.A.name + ^ name_to_string ctx def.name ^ " (" ^ Print.option_to_string T.RegionGroupId.to_string bid ^ ")\n")); (* Translate the declaration *) - let def_id = def.A.def_id in - let basename = def.name in + let def_id = def.def_id in + let llbc_name = def.name in + let name = name_to_string ctx llbc_name in (* Retrieve the signature *) let signature = ctx.sg in let regions_hierarchy = @@ -2999,7 +2983,7 @@ let translate_fun_decl (ctx : bs_ctx) (body : S.expression option) : fun_decl = log#ldebug (lazy ("SymbolicToPure.translate_fun_decl: " - ^ Print.fun_name_to_string def.A.name + ^ name_to_string ctx def.name ^ " (" ^ Print.option_to_string T.RegionGroupId.to_string bid ^ ")" ^ "\n- forward_inputs: " @@ -3030,14 +3014,15 @@ let translate_fun_decl (ctx : bs_ctx) (body : S.expression option) : fun_decl = let loop_id = None in (* Assemble the declaration *) - let def = + let def : fun_decl = { def_id; kind = def.kind; num_loops; loop_id; back_id = bid; - basename; + llbc_name; + name; signature; is_global_decl_body = def.is_global_decl_body; body; @@ -3051,8 +3036,9 @@ let translate_fun_decl (ctx : bs_ctx) (body : S.expression option) : fun_decl = (* return *) def -let translate_type_decls (type_decls : T.type_decl list) : type_decl list = - List.map translate_type_decl type_decls +let translate_type_decls (ctx : Contexts.decls_ctx) + (type_decls : T.type_decl list) : type_decl list = + List.map (translate_type_decl ctx) type_decls (** Translates function signatures. @@ -3105,11 +3091,11 @@ let translate_fun_signatures (decls_ctx : C.decls_ctx) (fun m (id, sg) -> RegularFunIdNotLoopMap.add id sg m) RegularFunIdNotLoopMap.empty translated -let translate_trait_decl (type_infos : TA.type_infos) - (trait_decl : A.trait_decl) : trait_decl = +let translate_trait_decl (ctx : Contexts.decls_ctx) (trait_decl : A.trait_decl) + : trait_decl = let { def_id; - name; + name = llbc_name; generics; preds; parent_clauses; @@ -3120,6 +3106,12 @@ let translate_trait_decl (type_infos : TA.type_infos) } : A.trait_decl = trait_decl in + let type_infos = ctx.type_ctx.type_infos in + let name = + Print.Types.name_to_string + (Print.Contexts.decls_ctx_to_fmt_env ctx) + llbc_name + in let generics = translate_generic_params generics in let preds = translate_predicates preds in let parent_clauses = List.map translate_trait_clause parent_clauses in @@ -3138,6 +3130,7 @@ let translate_trait_decl (type_infos : TA.type_infos) in { def_id; + llbc_name; name; generics; preds; @@ -3148,11 +3141,11 @@ let translate_trait_decl (type_infos : TA.type_infos) provided_methods; } -let translate_trait_impl (type_infos : TA.type_infos) - (trait_impl : A.trait_impl) : trait_impl = +let translate_trait_impl (ctx : Contexts.decls_ctx) (trait_impl : A.trait_impl) + : trait_impl = let { A.def_id; - name; + name = llbc_name; impl_trait; generics; preds; @@ -3164,9 +3157,15 @@ let translate_trait_impl (type_infos : TA.type_infos) } = trait_impl in + let type_infos = ctx.type_ctx.type_infos in let impl_trait = translate_trait_decl_ref (translate_fwd_ty type_infos) impl_trait in + let name = + Print.Types.name_to_string + (Print.Contexts.decls_ctx_to_fmt_env ctx) + llbc_name + in let generics = translate_generic_params generics in let preds = translate_predicates preds in let parent_trait_refs = List.map translate_strait_ref parent_trait_refs in @@ -3185,6 +3184,7 @@ let translate_trait_impl (type_infos : TA.type_infos) in { def_id; + llbc_name; name; impl_trait; generics; diff --git a/compiler/SynthesizeSymbolic.ml b/compiler/SynthesizeSymbolic.ml index ddb9d681..38efc53a 100644 --- a/compiler/SynthesizeSymbolic.ml +++ b/compiler/SynthesizeSymbolic.ml @@ -1,57 +1,52 @@ -module C = Collections -module T = Types -module PV = PrimitiveValues -module V = Values -module E = Expressions -module A = LlbcAst +open Types +open TypesUtils +open PrimitiveValues +open Expressions +open Values open SymbolicAst -let mk_mplace (p : E.place) (ctx : Contexts.eval_ctx) : mplace = +let mk_mplace (p : place) (ctx : Contexts.eval_ctx) : mplace = let bv = Contexts.ctx_lookup_var_binder ctx p.var_id in { bv; projection = p.projection } -let mk_opt_mplace (p : E.place option) (ctx : Contexts.eval_ctx) : mplace option - = +let mk_opt_mplace (p : place option) (ctx : Contexts.eval_ctx) : mplace option = Option.map (fun p -> mk_mplace p ctx) p -let mk_opt_place_from_op (op : E.operand) (ctx : Contexts.eval_ctx) : +let mk_opt_place_from_op (op : operand) (ctx : Contexts.eval_ctx) : mplace option = - match op with - | E.Copy p | E.Move p -> Some (mk_mplace p ctx) - | E.Constant _ -> None + match op with Copy p | Move p -> Some (mk_mplace p ctx) | Constant _ -> None let mk_meta (m : meta) (e : expression) : expression = Meta (m, e) -let synthesize_symbolic_expansion (sv : V.symbolic_value) - (place : mplace option) (seel : V.symbolic_expansion option list) - (el : expression list option) : expression option = +let synthesize_symbolic_expansion (sv : symbolic_value) (place : mplace option) + (seel : symbolic_expansion option list) (el : expression list option) : + expression option = match el with | None -> None | Some el -> let ls = List.combine seel el in (* Match on the symbolic value type to know which can of expansion happened *) let expansion = - match sv.V.sv_ty with - | T.TLiteral PV.TBool -> ( + match sv.sv_ty with + | TLiteral TBool -> ( (* Boolean expansion: there should be two branches *) match ls with | [ - (Some (V.SeLiteral (PV.VBool true)), true_exp); - (Some (V.SeLiteral (PV.VBool false)), false_exp); + (Some (SeLiteral (VBool true)), true_exp); + (Some (SeLiteral (VBool false)), false_exp); ] -> ExpandBool (true_exp, false_exp) | _ -> raise (Failure "Ill-formed boolean expansion")) - | T.TLiteral (PV.TInteger int_ty) -> + | TLiteral (TInteger 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 + let branches, otherwise = Collections.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 - = + let get_scalar (see : symbolic_expansion option) : scalar_value = match see with - | Some (V.SeLiteral (PV.VScalar cv)) -> - assert (cv.PV.int_ty = int_ty); + | Some (SeLiteral (VScalar cv)) -> + assert (cv.int_ty = int_ty); cv | _ -> raise (Failure "Unreachable") in @@ -64,12 +59,12 @@ let synthesize_symbolic_expansion (sv : V.symbolic_value) assert (otherwise_see = None); (* Return *) ExpandInt (int_ty, branches, otherwise) - | T.TAdt (_, _) -> + | TAdt (_, _) -> (* Branching: it is necessarily an enumeration expansion *) - let get_variant (see : V.symbolic_expansion option) : - T.VariantId.id option * V.symbolic_value list = + let get_variant (see : symbolic_expansion option) : + VariantId.id option * symbolic_value list = match see with - | Some (V.SeAdt (vid, fields)) -> (vid, fields) + | Some (SeAdt (vid, fields)) -> (vid, fields) | _ -> raise (Failure "Ill-formed branching ADT expansion") in let exp = @@ -80,29 +75,28 @@ let synthesize_symbolic_expansion (sv : V.symbolic_value) ls in ExpandAdt exp - | T.TRef (_, _, _) -> ( + | TRef (_, _, _) -> ( (* Reference expansion: there should be one branch *) match ls with | [ (Some see, exp) ] -> ExpandNoBranch (see, exp) | _ -> raise (Failure "Ill-formed borrow expansion")) - | T.TVar _ - | T.TLiteral TChar - | TNever | T.TTraitType _ | T.TArrow _ | T.TRawPtr _ -> + | TVar _ | TLiteral TChar | TNever | TTraitType _ | TArrow _ | TRawPtr _ + -> raise (Failure "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) (e : expression option) - : expression option = +let synthesize_symbolic_expansion_no_branching (sv : symbolic_value) + (place : mplace option) (see : symbolic_expansion) (e : expression option) : + expression option = let el = Option.map (fun e -> [ e ]) e in synthesize_symbolic_expansion sv place [ Some see ] el let synthesize_function_call (call_id : call_id) (ctx : Contexts.eval_ctx) - (abstractions : V.AbstractionId.id list) (generics : T.generic_args) - (args : V.typed_value list) (args_places : mplace option list) - (dest : V.symbolic_value) (dest_place : mplace option) - (e : expression option) : expression option = + (abstractions : AbstractionId.id list) (generics : generic_args) + (args : typed_value list) (args_places : mplace option list) + (dest : symbolic_value) (dest_place : mplace option) (e : expression option) + : expression option = Option.map (fun e -> let call = @@ -120,58 +114,56 @@ let synthesize_function_call (call_id : call_id) (ctx : Contexts.eval_ctx) FunCall (call, e)) e -let synthesize_global_eval (gid : A.GlobalDeclId.id) (dest : V.symbolic_value) +let synthesize_global_eval (gid : GlobalDeclId.id) (dest : symbolic_value) (e : expression option) : expression option = Option.map (fun e -> EvalGlobal (gid, dest, e)) e -let synthesize_regular_function_call (fun_id : A.fun_id_or_trait_method_ref) - (call_id : V.FunCallId.id) (ctx : Contexts.eval_ctx) - (abstractions : V.AbstractionId.id list) (generics : T.generic_args) - (args : V.typed_value list) (args_places : mplace option list) - (dest : V.symbolic_value) (dest_place : mplace option) - (e : expression option) : expression option = +let synthesize_regular_function_call (fun_id : fun_id_or_trait_method_ref) + (call_id : FunCallId.id) (ctx : Contexts.eval_ctx) + (abstractions : AbstractionId.id list) (generics : generic_args) + (args : typed_value list) (args_places : mplace option list) + (dest : symbolic_value) (dest_place : mplace option) (e : expression option) + : expression option = synthesize_function_call (Fun (fun_id, call_id)) ctx abstractions generics args args_places dest dest_place e -let synthesize_unary_op (ctx : Contexts.eval_ctx) (unop : E.unop) - (arg : V.typed_value) (arg_place : mplace option) (dest : V.symbolic_value) +let synthesize_unary_op (ctx : Contexts.eval_ctx) (unop : unop) + (arg : typed_value) (arg_place : mplace option) (dest : symbolic_value) (dest_place : mplace option) (e : expression option) : expression option = - let generics = TypesUtils.mk_empty_generic_args in + let generics = empty_generic_args in synthesize_function_call (Unop unop) ctx [] generics [ arg ] [ arg_place ] dest dest_place e -let synthesize_binary_op (ctx : Contexts.eval_ctx) (binop : E.binop) - (arg0 : V.typed_value) (arg0_place : mplace option) (arg1 : V.typed_value) - (arg1_place : mplace option) (dest : V.symbolic_value) +let synthesize_binary_op (ctx : Contexts.eval_ctx) (binop : binop) + (arg0 : typed_value) (arg0_place : mplace option) (arg1 : typed_value) + (arg1_place : mplace option) (dest : symbolic_value) (dest_place : mplace option) (e : expression option) : expression option = - let generics = TypesUtils.mk_empty_generic_args in + let generics = empty_generic_args in synthesize_function_call (Binop binop) ctx [] generics [ arg0; arg1 ] [ arg0_place; arg1_place ] dest dest_place e -let synthesize_end_abstraction (ctx : Contexts.eval_ctx) (abs : V.abs) +let synthesize_end_abstraction (ctx : Contexts.eval_ctx) (abs : abs) (e : expression option) : expression option = Option.map (fun e -> EndAbstraction (ctx, abs, e)) e let synthesize_assignment (ctx : Contexts.eval_ctx) (lplace : mplace) - (rvalue : V.typed_value) (rplace : mplace option) (e : expression option) : + (rvalue : typed_value) (rplace : mplace option) (e : expression option) : expression option = Option.map (fun e -> Meta (Assignment (ctx, lplace, rvalue, rplace), e)) e -let synthesize_assertion (ctx : Contexts.eval_ctx) (v : V.typed_value) +let synthesize_assertion (ctx : Contexts.eval_ctx) (v : typed_value) (e : expression option) = Option.map (fun e -> Assertion (ctx, v, e)) e let synthesize_forward_end (ctx : Contexts.eval_ctx) - (loop_input_values : V.typed_value V.SymbolicValueId.Map.t option) - (e : expression) (el : expression T.RegionGroupId.Map.t) = + (loop_input_values : typed_value SymbolicValueId.Map.t option) + (e : expression) (el : expression RegionGroupId.Map.t) = Some (ForwardEnd (ctx, loop_input_values, e, el)) -let synthesize_loop (loop_id : V.LoopId.id) - (input_svalues : V.symbolic_value list) - (fresh_svalues : V.SymbolicValueId.Set.t) - (rg_to_given_back_tys : - (T.RegionId.Set.t * T.ty list) T.RegionGroupId.Map.t) +let synthesize_loop (loop_id : LoopId.id) (input_svalues : symbolic_value list) + (fresh_svalues : SymbolicValueId.Set.t) + (rg_to_given_back_tys : (RegionId.Set.t * ty list) RegionGroupId.Map.t) (end_expr : expression option) (loop_expr : expression option) : expression option = match (end_expr, loop_expr) with diff --git a/compiler/TranslateCore.ml b/compiler/TranslateCore.ml index 3427fd43..a148175d 100644 --- a/compiler/TranslateCore.ml +++ b/compiler/TranslateCore.ml @@ -1,16 +1,11 @@ (** Some utilities for the translation *) -open InterpreterStatements -module L = Logging -module T = Types -module A = LlbcAst -module SA = SymbolicAst -module FA = FunsAnalysis +open Contexts (** The local logger *) -let log = L.translate_log +let log = Logging.translate_log -type trans_ctx = C.decls_ctx [@@deriving show] +type trans_ctx = decls_ctx [@@deriving show] type fun_and_loops = { f : Pure.fun_decl; loops : Pure.fun_decl list } type pure_fun_translation_no_loops = Pure.fun_decl * Pure.fun_decl list @@ -26,53 +21,8 @@ type pure_fun_translation = { backs : fun_and_loops list; } -let trans_ctx_to_type_formatter (ctx : trans_ctx) - (type_params : Pure.type_var list) - (const_generic_params : Pure.const_generic_var list) : - PrintPure.type_formatter = - let type_decls = ctx.type_ctx.type_decls in - let global_decls = ctx.global_ctx.global_decls in - let trait_decls = ctx.trait_decls_ctx.trait_decls in - let trait_impls = ctx.trait_impls_ctx.trait_impls in - PrintPure.mk_type_formatter type_decls global_decls trait_decls trait_impls - type_params const_generic_params +let trans_ctx_to_fmt_env (ctx : trans_ctx) : Print.fmt_env = + Print.Contexts.decls_ctx_to_fmt_env ctx -let type_decl_to_string (ctx : trans_ctx) (def : Pure.type_decl) : string = - let generics = def.generics in - let fmt = - trans_ctx_to_type_formatter ctx generics.types generics.const_generics - in - PrintPure.type_decl_to_string fmt def - -let type_id_to_string (ctx : trans_ctx) (id : Pure.TypeDeclId.id) : string = - Print.fun_name_to_string - (Pure.TypeDeclId.Map.find id ctx.type_ctx.type_decls).name - -let trans_ctx_to_ast_formatter (ctx : trans_ctx) - (type_params : Pure.type_var list) - (const_generic_params : Pure.const_generic_var list) : - PrintPure.ast_formatter = - let type_decls = ctx.type_ctx.type_decls in - let fun_decls = ctx.fun_ctx.fun_decls in - let global_decls = ctx.global_ctx.global_decls in - let trait_decls = ctx.trait_decls_ctx.trait_decls in - let trait_impls = ctx.trait_impls_ctx.trait_impls in - PrintPure.mk_ast_formatter type_decls fun_decls global_decls trait_decls - trait_impls type_params const_generic_params - -let fun_sig_to_string (ctx : trans_ctx) (sg : Pure.fun_sig) : string = - let generics = sg.generics in - let fmt = - trans_ctx_to_ast_formatter ctx generics.types generics.const_generics - in - PrintPure.fun_sig_to_string fmt sg - -let fun_decl_to_string (ctx : trans_ctx) (def : Pure.fun_decl) : string = - let generics = def.signature.generics in - let fmt = - trans_ctx_to_ast_formatter ctx generics.types generics.const_generics - 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_ctx.fun_decls).name +let trans_ctx_to_pure_fmt_env (ctx : trans_ctx) : PrintPure.fmt_env = + PrintPure.decls_ctx_to_fmt_env ctx diff --git a/compiler/TypesAnalysis.ml b/compiler/TypesAnalysis.ml index eddc1e42..659eac59 100644 --- a/compiler/TypesAnalysis.ml +++ b/compiler/TypesAnalysis.ml @@ -163,7 +163,7 @@ let analyze_full_ty (updated : bool ref) (infos : type_infos) let expl_info = { under_borrow = true; - under_mut_borrow = expl_info.under_mut_borrow || rkind = Mut; + under_mut_borrow = expl_info.under_mut_borrow || rkind = RMut; } in (* Continue exploring *) diff --git a/compiler/TypesUtils.ml b/compiler/TypesUtils.ml index 54a12023..52e12b9a 100644 --- a/compiler/TypesUtils.ml +++ b/compiler/TypesUtils.ml @@ -1,7 +1,6 @@ open Types open Utils include Charon.TypesUtils -module TA = TypesAnalysis (** Retuns true if the type contains borrows. @@ -9,9 +8,9 @@ module TA = TypesAnalysis 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 : ty) : bool = - let info = TA.analyze_ty infos ty in - info.TA.contains_borrow +let ty_has_borrows (infos : TypesAnalysis.type_infos) (ty : ty) : bool = + let info = TypesAnalysis.analyze_ty infos ty in + info.TypesAnalysis.contains_borrow (** Retuns true if the type contains nested borrows. @@ -19,14 +18,15 @@ let ty_has_borrows (infos : TA.type_infos) (ty : ty) : bool = 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 : ty) : bool = - let info = TA.analyze_ty infos ty in - info.TA.contains_nested_borrows +let ty_has_nested_borrows (infos : TypesAnalysis.type_infos) (ty : ty) : bool = + let info = TypesAnalysis.analyze_ty infos ty in + info.TypesAnalysis.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 : ty) : bool = - let info = TA.analyze_ty infos ty in - info.TA.contains_borrow_under_mut +let ty_has_borrow_under_mut (infos : TypesAnalysis.type_infos) (ty : ty) : bool + = + let info = TypesAnalysis.analyze_ty infos ty in + info.TypesAnalysis.contains_borrow_under_mut (** Small helper *) let raise_if_erased_ty_visitor = diff --git a/compiler/Values.ml b/compiler/Values.ml index 932530ff..6b1a782c 100644 --- a/compiler/Values.ml +++ b/compiler/Values.ml @@ -1,6 +1,5 @@ open Identifiers open Types -module PrimitiveValues = PrimitiveValues (* TODO(SH): I often write "abstract" (value, borrow content, etc.) while I should * write "abstraction" (because those values are not abstract, they simply are diff --git a/compiler/ValuesUtils.ml b/compiler/ValuesUtils.ml index 7880fc3a..0d3533c2 100644 --- a/compiler/ValuesUtils.ml +++ b/compiler/ValuesUtils.ml @@ -2,7 +2,6 @@ open Utils open TypesUtils open Types open Values -module TA = TypesAnalysis include PrimitiveValuesUtils (** Utility exception *) @@ -144,8 +143,9 @@ let outer_loans_in_value (v : typed_value) : bool = false with Found -> true -let find_first_primitively_copyable_sv_with_borrows (type_infos : TA.type_infos) - (v : typed_value) : symbolic_value option = +let find_first_primitively_copyable_sv_with_borrows + (type_infos : TypesAnalysis.type_infos) (v : typed_value) : + symbolic_value option = (* The visitor *) let obj = object @@ -175,8 +175,8 @@ let rec value_strip_shared_loans (v : typed_value) : typed_value = | _ -> v (** Check if a symbolic value has borrows *) -let symbolic_value_has_borrows (infos : TA.type_infos) (sv : symbolic_value) : - bool = +let symbolic_value_has_borrows (infos : TypesAnalysis.type_infos) + (sv : symbolic_value) : bool = ty_has_borrows infos sv.sv_ty (** Check if a value has borrows in **a general sense**. @@ -185,7 +185,7 @@ let symbolic_value_has_borrows (infos : TA.type_infos) (sv : symbolic_value) : - there are concrete borrows - there are symbolic values which may contain borrows *) -let value_has_borrows (infos : TA.type_infos) (v : value) : bool = +let value_has_borrows (infos : TypesAnalysis.type_infos) (v : value) : bool = let obj = object inherit [_] iter_typed_value @@ -226,7 +226,8 @@ let value_has_loans (v : value) : bool = - there are symbolic values which may contain borrows (symbolic values can't contain loans). *) -let value_has_loans_or_borrows (infos : TA.type_infos) (v : value) : bool = +let value_has_loans_or_borrows (infos : TypesAnalysis.type_infos) (v : value) : + bool = let obj = object inherit [_] iter_typed_value diff --git a/compiler/dune b/compiler/dune index bc3cc718..8a1edd02 100644 --- a/compiler/dune +++ b/compiler/dune @@ -47,7 +47,6 @@ LlbcOfJson Logging Meta - Names PrePasses Print PrintPure |