From b9f33bdd871a1bd7a1bd29f148dd05bd7990548b Mon Sep 17 00:00:00 2001 From: Son Ho Date: Sun, 12 Nov 2023 19:28:56 +0100 Subject: [PATCH] Remove the 'r type variable from the ty type definition --- compiler/AssociatedTypes.ml | 482 +++++++++---------------- compiler/Assumed.ml | 29 +- compiler/Contexts.ml | 239 ++++-------- compiler/Extract.ml | 26 +- compiler/ExtractBase.ml | 54 +-- compiler/ExtractTypes.ml | 42 +-- compiler/FunsAnalysis.ml | 4 +- compiler/Interpreter.ml | 11 +- compiler/InterpreterBorrows.ml | 52 +-- compiler/InterpreterBorrows.mli | 1 - compiler/InterpreterBorrowsCore.ml | 40 +- compiler/InterpreterExpansion.ml | 38 +- compiler/InterpreterExpressions.ml | 90 +++-- compiler/InterpreterLoopsCore.ml | 12 +- compiler/InterpreterLoopsFixedPoint.ml | 16 +- compiler/InterpreterLoopsJoinCtxs.ml | 51 ++- compiler/InterpreterLoopsMatchCtxs.ml | 87 ++--- compiler/InterpreterPaths.ml | 33 +- compiler/InterpreterPaths.mli | 7 +- compiler/InterpreterProjectors.ml | 35 +- compiler/InterpreterProjectors.mli | 6 +- compiler/InterpreterStatements.ml | 118 +++--- compiler/InterpreterUtils.ml | 83 ++--- compiler/Invariants.ml | 67 ++-- compiler/LlbcAst.ml | 9 +- compiler/LlbcAstUtils.ml | 8 +- compiler/Print.ml | 202 +++-------- compiler/PrintPure.ml | 24 +- compiler/Pure.ml | 12 +- compiler/PureMicroPasses.ml | 10 +- compiler/PureTypeCheck.ml | 12 +- compiler/PureUtils.ml | 56 +-- compiler/ReorderDecls.ml | 4 +- compiler/Substitute.ml | 426 ++++++++-------------- compiler/SymbolicAst.ml | 40 +- compiler/SymbolicToPure.ml | 219 +++++------ compiler/SynthesizeSymbolic.ml | 20 +- compiler/Translate.ml | 12 +- compiler/TypesAnalysis.ml | 24 +- compiler/TypesUtils.ml | 87 ++++- compiler/Values.ml | 298 ++++----------- compiler/ValuesUtils.ml | 30 +- 42 files changed, 1305 insertions(+), 1811 deletions(-) diff --git a/compiler/AssociatedTypes.ml b/compiler/AssociatedTypes.ml index 581e218cc..c76af138e 100644 --- a/compiler/AssociatedTypes.ml +++ b/compiler/AssociatedTypes.ml @@ -20,141 +20,80 @@ module PA = Print.EvalCtxLlbcAst (** The local logger *) let log = L.associated_types_log -let trait_type_ref_substitute (subst : ('r, 'r1) Subst.subst) - (r : 'r C.trait_type_ref) : 'r1 C.trait_type_ref = +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_ref = Subst.trait_ref_substitute subst trait_ref in { C.trait_ref; type_name } -(* TODO: how not to duplicate below? *) -module RTyOrd = struct - type t = T.rty +module TyOrd = struct + type t = T.ty - let compare = T.compare_rty - let to_string = T.show_rty - let pp_t = T.pp_rty - let show_t = T.show_rty + let compare = T.compare_ty + let to_string = T.show_ty + let pp_t = T.pp_ty + let show_t = T.show_ty end -module STyOrd = struct - type t = T.sty +module TyMap = Collections.MakeMap (TyOrd) - let compare = T.compare_sty - let to_string = T.show_sty - let pp_t = T.pp_sty - let show_t = T.show_sty -end - -module RTyMap = Collections.MakeMap (RTyOrd) -module STyMap = Collections.MakeMap (STyOrd) - -(* TODO: is it possible not to have this? *) -module type TypeWrapper = sig - type t -end - -(* TODO: don't manage to get the syntax right so using a functor *) -module MakeNormalizer - (R : TypeWrapper) - (RTyMap : Collections.Map with type key = R.t T.region T.ty) - (M : Collections.Map with type key = R.t T.region C.trait_type_ref) = -struct - let compute_norm_trait_types_from_preds - (trait_type_constraints : R.t T.region T.trait_type_constraint list) : - R.t T.region T.ty M.t = - (* Compute a union-find structure by recursively exploring the predicates and clauses *) - let norm : R.t T.region T.ty UF.elem RTyMap.t ref = ref RTyMap.empty in - let get_ref (ty : R.t T.region T.ty) : R.t T.region T.ty UF.elem = - match RTyMap.find_opt ty !norm with - | Some r -> r - | None -> - let r = UF.make ty in - norm := RTyMap.add ty r !norm; - r - in - let add_trait_type_constraint (c : R.t T.region T.trait_type_constraint) = - let trait_ty = T.TraitType (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 - (* Not sure the set operation is necessary, but I want to control which - representative is chosen *) - UF.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)) (RTyMap.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.TraitType (trait_ref, generics, type_name) -> - assert (generics = TypesUtils.mk_empty_generic_args); - Some ({ C.trait_ref; type_name }, v) - | _ -> None) - rbindings - in - M.of_list rbindings -end - -(** Compute the representative classes of trait associated types, for normalization *) -let compute_norm_trait_stypes_from_preds - (trait_type_constraints : T.strait_type_constraint list) : - T.sty C.STraitTypeRefMap.t = - (* Compute the normalization map for the types with regions *) - let module R = struct - type t = T.region_var_id - end in - let module M = C.STraitTypeRefMap in - let module Norm = MakeNormalizer (R) (STyMap) (M) in - Norm.compute_norm_trait_types_from_preds trait_type_constraints - -(** Compute the representative classes of trait associated types, for normalization *) let compute_norm_trait_types_from_preds - (trait_type_constraints : T.rtrait_type_constraint list) : - T.ety C.ETraitTypeRefMap.t * T.rty C.RTraitTypeRefMap.t = - (* Compute the normalization map for the types with regions *) - let module R = struct - type t = T.region_id - end in - let module M = C.RTraitTypeRefMap in - let module Norm = MakeNormalizer (R) (RTyMap) (M) in + (trait_type_constraints : T.trait_type_constraint list) : + T.ty C.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 = + match TyMap.find_opt ty !norm with + | Some r -> r + | None -> + let r = UF.make ty in + norm := TyMap.add ty r !norm; + r + in + let add_trait_type_constraint (c : T.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.TraitType (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 + (* Not sure the set operation is necessary, but I want to control which + representative is chosen *) + UF.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 = - Norm.compute_norm_trait_types_from_preds trait_type_constraints + List.map (fun (k, v) -> (k, UF.get v)) (TyMap.bindings !norm) in - (* Compute the normalization map for the types with erased regions *) - let ebindings = - List.map + (* Filter the keys to keep only the trait type aliases *) + let rbindings = + List.filter_map (fun (k, v) -> - ( trait_type_ref_substitute Subst.erase_regions_subst k, - Subst.erase_regions v )) - (M.bindings rbindings) - in - (C.ETraitTypeRefMap.of_list ebindings, rbindings) - -let ctx_add_norm_trait_stypes_from_preds (ctx : C.eval_ctx) - (trait_type_constraints : T.strait_type_constraint list) : C.eval_ctx = - let norm_trait_stypes = - compute_norm_trait_stypes_from_preds trait_type_constraints + match k with + | T.TraitType (trait_ref, generics, type_name) -> + assert (generics = TypesUtils.mk_empty_generic_args); + Some ({ C.trait_ref; type_name }, v) + | _ -> None) + rbindings in - { ctx with C.norm_trait_stypes } + C.TraitTypeRefMap.of_list rbindings let ctx_add_norm_trait_types_from_preds (ctx : C.eval_ctx) - (trait_type_constraints : T.rtrait_type_constraint list) : C.eval_ctx = - let norm_trait_etypes, norm_trait_rtypes = + (trait_type_constraints : T.trait_type_constraint list) : C.eval_ctx = + let norm_trait_types = compute_norm_trait_types_from_preds trait_type_constraints in - { ctx with C.norm_trait_etypes; norm_trait_rtypes } + { ctx with C.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 : 'r T.trait_instance_id) : bool = +let rec trait_instance_id_is_local_clause (id : T.trait_instance_id) : bool = match id with | T.Self | Clause _ -> true | TraitImpl _ | BuiltinOrAuto _ | TraitRef _ | UnknownTrait _ | FnPointer _ -> @@ -165,75 +104,52 @@ let rec trait_instance_id_is_local_clause (id : 'r T.trait_instance_id) : bool = (** About the conversion functions: for now we need them (TODO: merge ety, rty, etc.), but they should be applied to types without regions. *) -type 'r norm_ctx = { - ctx : C.eval_ctx; - get_ty_repr : 'r C.trait_type_ref -> 'r T.ty option; - convert_ety : T.ety -> 'r T.ty; (* TODO: remove? *) - convert_etrait_ref : T.etrait_ref -> 'r T.trait_ref; (* TODO: remove? *) - ty_to_string : 'r T.ty -> string; - generic_params_to_string : T.generic_params -> string; - generic_args_to_string : 'r T.generic_args -> string; - trait_ref_to_string : 'r T.trait_ref -> string; - trait_instance_id_to_string : 'r T.trait_instance_id -> string; - pp_r : Format.formatter -> 'r -> unit; -} - -(** Small utility to lookup trait impls, together with a substitution. - - Remark: one reason we have those small helpers is that all functions are - parameterized by a type variable 'r. The OCaml type inferencer and type - checker are however not very good at generating precise error messages in - this context: if in the body of the function we have an overly constrained - usage of 'r (for instance, the type inferencer deduces 'r should be - [T.erased_region]), it will not be able to pinpoint the location which - introduced the constraints and we just get a type-checking error for the - whole function. The fact that we have mutually recursive functions makes it - worse (the type-checker sometimes indicates a well-typed function as not - well-typed, because it calls a not well-typed function...). - By isolating the places where such errors typically happen in small helpers - (i.e., the places where we convert between different types of regions by - performing substitutions), we make maintenance a lot easier. - *) -let ctx_lookup_trait_impl : - 'r. - 'r norm_ctx -> - T.TraitImplId.id -> - 'r T.generic_args -> - A.trait_impl * (T.region_var_id T.region, 'r) Subst.subst = - fun ctx impl_id generics -> +type norm_ctx = { ctx : C.eval_ctx } + +let ctx_get_ty_repr (ctx : norm_ctx) (x : C.trait_type_ref) : T.ty option = + C.TraitTypeRefMap.find_opt x ctx.ctx.norm_trait_types + +let ty_to_string (ctx : norm_ctx) (ty : T.ty) : string = + PA.ty_to_string ctx.ctx ty + +let trait_ref_to_string (ctx : norm_ctx) (x : T.trait_ref) : string = + PA.trait_ref_to_string ctx.ctx x + +let trait_instance_id_to_string (ctx : norm_ctx) (x : T.trait_instance_id) : + string = + PA.trait_instance_id_to_string ctx.ctx x + +let generic_args_to_string (ctx : norm_ctx) (x : T.generic_args) : string = + PA.generic_args_to_string ctx.ctx x + +let generic_params_to_string (ctx : norm_ctx) (x : T.generic_params) : string = + "<" ^ String.concat ", " (fst (PA.generic_params_to_strings ctx.ctx x)) ^ ">" + +(** Small utility to lookup trait impls, together with a substitution. *) +let ctx_lookup_trait_impl (ctx : norm_ctx) (impl_id : T.TraitImplId.id) + (generics : T.generic_args) : A.trait_impl * Subst.subst = (* Lookup the implementation *) let trait_impl = C.ctx_lookup_trait_impl ctx.ctx impl_id in (* The substitution *) let tr_self = T.UnknownTrait __FUNCTION__ in let subst = - Subst.make_subst_from_generics_no_regions trait_impl.generics generics - tr_self + Subst.make_subst_from_generics trait_impl.generics generics tr_self in (* Return *) (trait_impl, subst) -let ctx_lookup_trait_impl_ty : - 'r. - 'r norm_ctx -> T.TraitImplId.id -> 'r T.generic_args -> string -> 'r T.ty - = - fun ctx impl_id generics type_name -> +let ctx_lookup_trait_impl_ty (ctx : norm_ctx) (impl_id : T.TraitImplId.id) + (generics : T.generic_args) (type_name : string) : T.ty = (* Lookup the implementation *) let trait_impl, subst = ctx_lookup_trait_impl ctx impl_id generics in (* Lookup the type *) let ty = snd (List.assoc type_name trait_impl.types) in - (* Annoying: convert etype to an stype - TODO: how to avoid that? *) - let ty : T.sty = TypesUtils.ety_no_regions_to_gr_ty ty in (* Substitute *) Subst.ty_substitute subst ty -let ctx_lookup_trait_impl_parent_clause : - 'r. - 'r norm_ctx -> - T.TraitImplId.id -> - 'r T.generic_args -> - T.TraitClauseId.id -> - 'r T.trait_ref = - fun ctx impl_id generics clause_id -> +let 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 = (* Lookup the implementation *) let trait_impl, subst = ctx_lookup_trait_impl ctx impl_id generics in (* Lookup the clause *) @@ -243,15 +159,9 @@ let ctx_lookup_trait_impl_parent_clause : (* Substitute *) Subst.trait_ref_substitute subst clause -let ctx_lookup_trait_impl_item_clause : - 'r. - 'r norm_ctx -> - T.TraitImplId.id -> - 'r T.generic_args -> - string -> - T.TraitClauseId.id -> - 'r T.trait_ref = - fun ctx impl_id generics item_name clause_id -> +let 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 = (* Lookup the implementation *) let trait_impl, subst = ctx_lookup_trait_impl ctx impl_id generics in (* Lookup the item then its clause *) @@ -259,10 +169,6 @@ let ctx_lookup_trait_impl_item_clause : let clause = T.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 - (* Annoying: convert etype to an stype - TODO: how to avoid that? *) - let clause : T.strait_ref = - TypesUtils.etrait_ref_no_regions_to_gr_trait_ref clause - in (* Substitute *) Subst.trait_ref_substitute subst clause @@ -272,12 +178,11 @@ let ctx_lookup_trait_impl_item_clause : See the comments for {!ctx_normalize_trait_instance_id}. *) -let rec ctx_normalize_ty : 'r. 'r norm_ctx -> 'r T.ty -> 'r T.ty = - fun ctx ty -> - log#ldebug (lazy ("ctx_normalize_ty: " ^ ctx.ty_to_string ty)); +let rec ctx_normalize_ty (ctx : norm_ctx) (ty : T.ty) : T.ty = + log#ldebug (lazy ("ctx_normalize_ty: " ^ ty_to_string ctx ty)); match ty with - | T.Adt (id, generics) -> Adt (id, ctx_normalize_generic_args ctx generics) - | TypeVar _ | Literal _ | Never -> ty + | T.TAdt (id, generics) -> TAdt (id, ctx_normalize_generic_args ctx generics) + | TypeVar _ | TLiteral _ | Never -> ty | Ref (r, ty, rkind) -> let ty = ctx_normalize_ty ctx ty in T.Ref (r, ty, rkind) @@ -291,19 +196,18 @@ let rec ctx_normalize_ty : 'r. 'r norm_ctx -> 'r T.ty -> 'r T.ty = | TraitType (trait_ref, generics, type_name) -> ( log#ldebug (lazy - ("ctx_normalize_ty:\n- trait type: " ^ ctx.ty_to_string ty + ("ctx_normalize_ty:\n- trait type: " ^ ty_to_string ctx ty ^ "\n- trait_ref: " - ^ ctx.trait_ref_to_string trait_ref - ^ "\n- raw trait ref:\n" - ^ T.show_trait_ref ctx.pp_r trait_ref + ^ trait_ref_to_string ctx trait_ref + ^ "\n- raw trait ref:\n" ^ T.show_trait_ref trait_ref ^ "\n- generics:\n" - ^ ctx.generic_args_to_string generics)); + ^ generic_args_to_string ctx generics)); (* Normalize and attempt to project the type from the trait ref *) let trait_ref = ctx_normalize_trait_ref ctx trait_ref in let generics = 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 : 'r T.ty = + let ty : T.ty = match trait_ref.trait_id with | T.TraitRef { T.trait_id = T.TraitImpl impl_id; generics = ref_generics; _ } -> @@ -311,7 +215,7 @@ let rec ctx_normalize_ty : 'r. 'r norm_ctx -> 'r T.ty -> 'r T.ty = log#ldebug (lazy ("ctx_normalize_ty: trait type: trait ref: " - ^ ctx.ty_to_string ty)); + ^ ty_to_string ctx ty)); (* Lookup the type *) let ty = ctx_lookup_trait_impl_ty ctx impl_id trait_ref.generics type_name @@ -322,10 +226,9 @@ let rec ctx_normalize_ty : 'r. 'r norm_ctx -> 'r T.ty -> 'r T.ty = log#ldebug (lazy ("ctx_normalize_ty (trait impl):\n- trait type: " - ^ ctx.ty_to_string ty ^ "\n- trait_ref: " - ^ ctx.trait_ref_to_string trait_ref - ^ "\n- raw trait ref:\n" - ^ T.show_trait_ref ctx.pp_r 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)); (* 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 @@ -342,17 +245,16 @@ let rec ctx_normalize_ty : 'r. 'r norm_ctx -> 'r T.ty -> 'r T.ty = log#ldebug (lazy ("ctx_normalize_ty: trait type: not a trait ref: " - ^ ctx.ty_to_string ty ^ "\n- trait_ref: " - ^ ctx.trait_ref_to_string trait_ref - ^ "\n- raw trait ref:\n" - ^ T.show_trait_ref ctx.pp_r 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)); (* We can't project *) assert (trait_instance_id_is_local_clause trait_ref.trait_id); T.TraitType (trait_ref, generics, type_name) in - let tr : 'r C.trait_type_ref = { C.trait_ref; type_name } in + let tr : C.trait_type_ref = { C.trait_ref; type_name } in (* Lookup the representative, if there is *) - match ctx.get_ty_repr tr with None -> ty | Some ty -> ty) + match ctx_get_ty_repr ctx tr with None -> ty | Some ty -> ty) (** This returns the normalized trait instance id together with an optional reference to a trait **implementation** (the `trait_ref` we return has @@ -398,12 +300,8 @@ let rec ctx_normalize_ty : 'r. 'r norm_ctx -> 'r T.ty -> 'r T.ty = In this case we can lookup the trait implementation and recursively project over it. *) -and ctx_normalize_trait_instance_id : - 'r. - 'r norm_ctx -> - 'r T.trait_instance_id -> - 'r T.trait_instance_id * 'r T.trait_ref option = - fun ctx id -> +and ctx_normalize_trait_instance_id (ctx : norm_ctx) (id : T.trait_instance_id) + : T.trait_instance_id * T.trait_ref option = match id with | Self -> (id, None) | TraitImpl _ -> @@ -481,7 +379,7 @@ and ctx_normalize_trait_instance_id : (* Normalize the generics *) let generics = ctx_normalize_generic_args ctx generics in let trait_decl_ref = ctx_normalize_trait_decl_ref ctx trait_decl_ref in - let trait_ref : 'r T.trait_ref = + let trait_ref : T.trait_ref = { T.trait_id = T.TraitImpl trait_id; generics; trait_decl_ref } in (TraitRef trait_ref, Some trait_ref) @@ -500,21 +398,20 @@ and ctx_normalize_trait_instance_id : (* This is actually an error case *) (id, None) -and ctx_normalize_generic_args (ctx : 'r norm_ctx) - (generics : 'r T.generic_args) : 'r T.generic_args = +and ctx_normalize_generic_args (ctx : norm_ctx) (generics : T.generic_args) : + T.generic_args = let { T.regions; types; const_generics; trait_refs } = generics in let types = List.map (ctx_normalize_ty ctx) types in let trait_refs = List.map (ctx_normalize_trait_ref ctx) trait_refs in { T.regions; types; const_generics; trait_refs } -and ctx_normalize_trait_ref (ctx : 'r norm_ctx) (trait_ref : 'r T.trait_ref) : - 'r T.trait_ref = +and ctx_normalize_trait_ref (ctx : norm_ctx) (trait_ref : T.trait_ref) : + T.trait_ref = log#ldebug (lazy ("ctx_normalize_trait_ref: " - ^ ctx.trait_ref_to_string trait_ref - ^ "\n- raw trait ref:\n" - ^ T.show_trait_ref ctx.pp_r 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 (* Check if the id is an impl, otherwise normalize it *) let trait_id, norm_trait_ref = ctx_normalize_trait_instance_id ctx trait_id in @@ -523,7 +420,7 @@ and ctx_normalize_trait_ref (ctx : 'r norm_ctx) (trait_ref : 'r T.trait_ref) : log#ldebug (lazy ("ctx_normalize_trait_ref: no norm: " - ^ ctx.trait_instance_id_to_string trait_id)); + ^ trait_instance_id_to_string ctx trait_id)); let generics = ctx_normalize_generic_args ctx generics in let trait_decl_ref = ctx_normalize_trait_decl_ref ctx trait_decl_ref in { T.trait_id; generics; trait_decl_ref } @@ -531,151 +428,108 @@ and ctx_normalize_trait_ref (ctx : 'r norm_ctx) (trait_ref : 'r T.trait_ref) : log#ldebug (lazy ("ctx_normalize_trait_ref: normalized to: " - ^ ctx.trait_ref_to_string trait_ref)); + ^ trait_ref_to_string ctx trait_ref)); assert (generics = TypesUtils.mk_empty_generic_args); trait_ref (* Not sure this one is really necessary *) -and ctx_normalize_trait_decl_ref (ctx : 'r norm_ctx) - (trait_decl_ref : 'r T.trait_decl_ref) : 'r T.trait_decl_ref = +and 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 let decl_generics = ctx_normalize_generic_args ctx decl_generics in { T.trait_decl_id; decl_generics } -let ctx_normalize_trait_type_constraint (ctx : 'r norm_ctx) - (ttc : 'r T.trait_type_constraint) : 'r T.trait_type_constraint = +let 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 let trait_ref = ctx_normalize_trait_ref ctx trait_ref in let generics = ctx_normalize_generic_args ctx generics in let ty = ctx_normalize_ty ctx ty in { T.trait_ref; generics; type_name; ty } -let generic_params_to_string ctx x = - "<" ^ String.concat ", " (fst (PA.generic_params_to_strings ctx x)) ^ ">" - -let mk_snorm_ctx (ctx : C.eval_ctx) : T.RegionVarId.id T.region norm_ctx = - let get_ty_repr x = C.STraitTypeRefMap.find_opt x ctx.norm_trait_stypes in - { - ctx; - get_ty_repr; - convert_ety = TypesUtils.ety_no_regions_to_sty; - convert_etrait_ref = TypesUtils.etrait_ref_no_regions_to_gr_trait_ref; - ty_to_string = PA.sty_to_string ctx; - generic_params_to_string = generic_params_to_string ctx; - generic_args_to_string = PA.sgeneric_args_to_string ctx; - trait_ref_to_string = PA.strait_ref_to_string ctx; - trait_instance_id_to_string = PA.strait_instance_id_to_string ctx; - pp_r = T.pp_region T.pp_region_var_id; - } - -let mk_rnorm_ctx (ctx : C.eval_ctx) : T.RegionId.id T.region norm_ctx = - let get_ty_repr x = C.RTraitTypeRefMap.find_opt x ctx.norm_trait_rtypes in - { - ctx; - get_ty_repr; - convert_ety = TypesUtils.ety_no_regions_to_rty; - convert_etrait_ref = TypesUtils.etrait_ref_no_regions_to_gr_trait_ref; - ty_to_string = PA.rty_to_string ctx; - generic_params_to_string = generic_params_to_string ctx; - generic_args_to_string = PA.rgeneric_args_to_string ctx; - trait_ref_to_string = PA.rtrait_ref_to_string ctx; - trait_instance_id_to_string = PA.rtrait_instance_id_to_string ctx; - pp_r = T.pp_region T.pp_region_id; - } - -let mk_enorm_ctx (ctx : C.eval_ctx) : T.erased_region norm_ctx = - let get_ty_repr x = C.ETraitTypeRefMap.find_opt x ctx.norm_trait_etypes in - { - ctx; - get_ty_repr; - convert_ety = (fun x -> x); - convert_etrait_ref = (fun x -> x); - ty_to_string = PA.ety_to_string ctx; - generic_params_to_string = generic_params_to_string ctx; - generic_args_to_string = PA.egeneric_args_to_string ctx; - trait_ref_to_string = PA.etrait_ref_to_string ctx; - trait_instance_id_to_string = PA.etrait_instance_id_to_string ctx; - pp_r = T.pp_erased_region; - } - -let ctx_normalize_sty (ctx : C.eval_ctx) (ty : T.sty) : T.sty = - ctx_normalize_ty (mk_snorm_ctx ctx) ty - -let ctx_normalize_rty (ctx : C.eval_ctx) (ty : T.rty) : T.rty = - ctx_normalize_ty (mk_rnorm_ctx ctx) ty - -let ctx_normalize_ety (ctx : C.eval_ctx) (ty : T.ety) : T.ety = - ctx_normalize_ty (mk_enorm_ctx ctx) ty - -let ctx_normalize_rtrait_type_constraint (ctx : C.eval_ctx) - (ttc : T.rtrait_type_constraint) : T.rtrait_type_constraint = - ctx_normalize_trait_type_constraint (mk_rnorm_ctx ctx) ttc - -(** Same as [type_decl_get_instantiated_variants_fields_rtypes] but normalizes the types *) +let mk_norm_ctx (ctx : C.eval_ctx) : norm_ctx = { ctx } + +let ctx_normalize_ty (ctx : C.eval_ctx) (ty : T.ty) : T.ty = + 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 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 = + 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.rgeneric_args) : - (T.VariantId.id option * T.rty list) list = + (def : T.type_decl) (generics : T.generic_args) : + (T.VariantId.id option * T.ty list) list = let res = - Subst.type_decl_get_instantiated_variants_fields_rtypes def generics + Subst.type_decl_get_instantiated_variants_fields_types def generics in List.map (fun (variant_id, types) -> - (variant_id, List.map (ctx_normalize_rty ctx) types)) + (variant_id, List.map (ctx_normalize_ty ctx) types)) res -(** Same as [type_decl_get_instantiated_field_rtypes] but normalizes the types *) +(** 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.rgeneric_args) : - T.rty list = + (opt_variant_id : T.VariantId.id option) (generics : T.generic_args) : + T.ty list = let types = - Subst.type_decl_get_instantiated_field_rtypes def opt_variant_id generics + Subst.type_decl_get_instantiated_field_types def opt_variant_id generics in - List.map (ctx_normalize_rty ctx) types + 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.rgeneric_args) : - T.rty list = + (adt : V.adt_value) (id : T.type_id) (generics : T.generic_args) : T.ty list + = let types = - Subst.ctx_adt_value_get_instantiated_field_rtypes ctx adt id generics + Subst.ctx_adt_value_get_instantiated_field_types ctx adt id generics in - List.map (ctx_normalize_rty ctx) types + List.map (ctx_normalize_ty ctx) types -(** Same as [ctx_adt_value_get_instantiated_field_etypes] but normalizes the types *) +(** 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.egeneric_args) : - T.ety list = + (opt_variant_id : T.VariantId.id option) (generics : T.generic_args) : + T.ty list = let types = - Subst.type_decl_get_instantiated_field_etypes def opt_variant_id generics + Subst.type_decl_get_instantiated_field_types def opt_variant_id generics in - List.map (ctx_normalize_ety ctx) types + let types = List.map (ctx_normalize_ty ctx) types in + List.map Subst.erase_regions types -(** Same as [ctx_adt_get_instantiated_field_etypes] but normalizes the types *) +(** 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.egeneric_args) : T.ety list = + (generics : T.generic_args) : T.ty list = let types = - Subst.ctx_adt_get_instantiated_field_etypes ctx def_id opt_variant_id + Subst.ctx_adt_get_instantiated_field_types ctx def_id opt_variant_id generics in - List.map (ctx_normalize_ety ctx) types + let types = List.map (ctx_normalize_ty ctx) types in + 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.RegionVarId.id -> T.RegionId.id) - (ty_subst : T.TypeVarId.id -> T.rty) + (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.rtrait_instance_id) - (tr_self : T.rtrait_instance_id) (sg : A.fun_sig) : A.inst_fun_sig = + (tr_subst : T.TraitClauseId.id -> T.trait_instance_id) + (tr_self : T.trait_instance_id) (sg : A.fun_sig) : A.inst_fun_sig = let sg = Subst.substitute_signature asubst r_subst ty_subst cg_subst tr_subst tr_self sg in let { A.regions_hierarchy; inputs; output; trait_type_constraints } = sg in - let inputs = List.map (ctx_normalize_rty ctx) inputs in - let output = ctx_normalize_rty ctx output in + let inputs = List.map (ctx_normalize_ty ctx) inputs in + let output = ctx_normalize_ty ctx output in let trait_type_constraints = - List.map (ctx_normalize_rtrait_type_constraint ctx) trait_type_constraints + List.map (ctx_normalize_trait_type_constraint ctx) trait_type_constraints in { regions_hierarchy; inputs; output; trait_type_constraints } diff --git a/compiler/Assumed.ml b/compiler/Assumed.ml index 79f6b0d4f..d8f191733 100644 --- a/compiler/Assumed.ml +++ b/compiler/Assumed.ml @@ -37,11 +37,11 @@ module A = LlbcAst module Sig = struct (** A few utilities *) - let rvar_id_0 = T.RegionVarId.of_int 0 - let rvar_0 : T.RegionVarId.id T.region = T.Var rvar_id_0 + let 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.sty = T.TypeVar tvar_id_0 + let tvar_0 : T.ty = T.TypeVar tvar_id_0 let cgvar_id_0 = T.ConstGenericVarId.of_int 0 let cgvar_0 : T.const_generic = T.ConstGenericVar cgvar_id_0 @@ -49,36 +49,35 @@ module Sig = struct let region_param_0 : T.region_var = { T.index = rvar_id_0; name = Some "'a" } (** Region group: [{ parent={}; regions:{'a of id 0} }] *) - let region_group_0 : T.region_var_group = + let region_group_0 : T.region_group = { T.id = rg_id_0; regions = [ rvar_id_0 ]; parents = [] } (** Type parameter [T] of id 0 *) let type_param_0 : T.type_var = { T.index = tvar_id_0; name = "T" } - let usize_ty : T.sty = T.Literal (Integer Usize) + let usize_ty : T.ty = T.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 = Integer Usize } + { T.index = cgvar_id_0; name = "N"; ty = TInteger Usize } let empty_const_generic_params : T.const_generic_var list = [] - let mk_generic_args regions types const_generics : T.sgeneric_args = + let mk_generic_args regions types const_generics : T.generic_args = { regions; types; const_generics; trait_refs = [] } let mk_generic_params regions types const_generics : T.generic_params = { regions; types; const_generics; trait_clauses = [] } - let mk_ref_ty (r : T.RegionVarId.id T.region) (ty : T.sty) (is_mut : bool) : - T.sty = + 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 mk_ref_ty r ty ref_kind - let mk_array_ty (ty : T.sty) (cg : T.const_generic) : T.sty = - Adt (Assumed Array, mk_generic_args [] [ ty ] [ cg ]) + let mk_array_ty (ty : T.ty) (cg : T.const_generic) : T.ty = + TAdt (TAssumed TArray, mk_generic_args [] [ ty ] [ cg ]) - let mk_slice_ty (ty : T.sty) : T.sty = - Adt (Assumed Slice, mk_generic_args [] [ ty ] []) + let mk_slice_ty (ty : T.ty) : T.ty = + TAdt (TAssumed TSlice, mk_generic_args [] [ ty ] []) let mk_sig generics regions_hierarchy inputs output : A.fun_sig = let preds : T.predicates = @@ -125,8 +124,8 @@ module Sig = struct borrow. *) let mk_array_slice_borrow_sig (cgs : T.const_generic_var list) - (input_ty : T.TypeVarId.id -> T.sty) (index_ty : T.sty option) - (output_ty : T.TypeVarId.id -> T.sty) (is_mut : bool) : A.fun_sig = + (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 generics = mk_generic_params [ region_param_0 ] [ type_param_0 ] cgs (* <'a, T> *) in diff --git a/compiler/Contexts.ml b/compiler/Contexts.ml index dac64a9a6..9a20a6ccc 100644 --- a/compiler/Contexts.ml +++ b/compiler/Contexts.ml @@ -112,16 +112,16 @@ let reset_global_counters () = fun_call_id_counter := FunCallId.generator_zero; dummy_var_id_counter := DummyVarId.generator_zero -(** Ancestor for {!var_binder} iter visitor *) -class ['self] iter_var_binder_base = +(** Ancestor for {!env} iter visitor *) +class ['self] iter_env_base = object (_self : 'self) inherit [_] iter_abs method visit_var_id : 'env -> var_id -> unit = fun _ _ -> () method visit_dummy_var_id : 'env -> dummy_var_id -> unit = fun _ _ -> () end -(** Ancestor for {!var_binder} map visitor *) -class ['self] map_var_binder_base = +(** Ancestor for {!env} map visitor *) +class ['self] map_env_base = object (_self : 'self) inherit [_] map_abs method visit_var_id : 'env -> var_id -> var_id = fun _ x -> x @@ -135,97 +135,29 @@ type var_binder = { index : var_id; (** Unique variable identifier *) name : string option; (** Possible name *) } -[@@deriving - show, - visitors - { - name = "iter_var_binder"; - variety = "iter"; - ancestors = [ "iter_var_binder_base" ]; - nude = true (* Don't inherit {!VisitorsRuntime.iter} *); - concrete = true; - }, - visitors - { - name = "map_var_binder"; - variety = "map"; - ancestors = [ "map_var_binder_base" ]; - nude = true (* Don't inherit {!VisitorsRuntime.iter} *); - concrete = true; - }] (** A binder, for a "real" variable or a dummy variable *) -type binder = VarBinder of var_binder | DummyBinder of dummy_var_id -[@@deriving - show, - visitors - { - name = "iter_binder"; - variety = "iter"; - ancestors = [ "iter_var_binder" ]; - nude = true (* Don't inherit {!VisitorsRuntime.iter} *); - concrete = true; - }, - visitors - { - name = "map_binder"; - variety = "map"; - ancestors = [ "map_var_binder" ]; - nude = true (* Don't inherit {!VisitorsRuntime.iter} *); - concrete = true; - }] - -(** Ancestor for {!env_elem} iter visitor *) -class ['self] iter_env_elem_base = - object (_self : 'self) - inherit [_] iter_binder - end - -(** Ancestor for {!env_elem} map visitor *) -class ['self] map_env_elem_base = - object (_self : 'self) - inherit [_] map_binder - end +and binder = BVar of var_binder | BDummy of dummy_var_id (** Environment value: mapping from variable to value, abstraction (only used in symbolic mode) or stack frame delimiter. - - TODO: rename Var (-> Binding?) *) -type env_elem = - | Var of binder * typed_value +and env_elem = + | EBinding of binder * typed_value (** Variable binding - the binder is None if the variable is a dummy variable (we use dummy variables to store temporaries while doing bookkeeping such as ending borrows for instance). *) - | Abs of abs - | Frame -[@@deriving - show, - visitors - { - name = "iter_env_elem"; - variety = "iter"; - ancestors = [ "iter_env_elem_base" ]; - nude = true (* Don't inherit {!VisitorsRuntime.iter} *); - concrete = true; - }, - visitors - { - name = "map_env_elem"; - variety = "map"; - ancestors = [ "map_env_elem_base" ]; - nude = true (* Don't inherit {!VisitorsRuntime.iter} *); - concrete = true; - }] + | EAbs of abs + | EFrame -type env = env_elem list +and env = env_elem list [@@deriving show, visitors { name = "iter_env"; variety = "iter"; - ancestors = [ "iter_env_elem" ]; + ancestors = [ "iter_env_base" ]; nude = true (* Don't inherit {!VisitorsRuntime.iter} *); concrete = true; }, @@ -233,7 +165,7 @@ type env = env_elem list { name = "map_env"; variety = "map"; - ancestors = [ "map_env_elem" ]; + ancestors = [ "map_env_base" ]; nude = true (* Don't inherit {!VisitorsRuntime.iter} *); concrete = true; }] @@ -280,48 +212,20 @@ type decls_ctx = { [@@deriving show] (** A reference to a trait associated type *) -type 'r trait_type_ref = { trait_ref : 'r trait_ref; type_name : string } -[@@deriving show, ord] - -type etrait_type_ref = erased_region trait_type_ref [@@deriving show, ord] - -type rtrait_type_ref = Types.RegionId.id Types.region trait_type_ref -[@@deriving show, ord] - -type strait_type_ref = Types.RegionVarId.id Types.region trait_type_ref +type trait_type_ref = { trait_ref : trait_ref; type_name : string } [@@deriving show, ord] (* TODO: correctly use the functors so as not to have a duplication below *) -module ETraitTypeRefOrd = struct - type t = etrait_type_ref +module TraitTypeRefOrd = struct + type t = trait_type_ref - let compare = compare_etrait_type_ref - let to_string = show_etrait_type_ref - let pp_t = pp_etrait_type_ref - let show_t = show_etrait_type_ref + let compare = compare_trait_type_ref + let to_string = show_trait_type_ref + let pp_t = pp_trait_type_ref + let show_t = show_trait_type_ref end -module RTraitTypeRefOrd = struct - type t = rtrait_type_ref - - let compare = compare_rtrait_type_ref - let to_string = show_rtrait_type_ref - let pp_t = pp_rtrait_type_ref - let show_t = show_rtrait_type_ref -end - -module STraitTypeRefOrd = struct - type t = strait_type_ref - - let compare = compare_strait_type_ref - let to_string = show_strait_type_ref - let pp_t = pp_strait_type_ref - let show_t = show_strait_type_ref -end - -module ETraitTypeRefMap = Collections.MakeMap (ETraitTypeRefOrd) -module RTraitTypeRefMap = Collections.MakeMap (RTraitTypeRefOrd) -module STraitTypeRefMap = Collections.MakeMap (STraitTypeRefOrd) +module TraitTypeRefMap = Collections.MakeMap (TraitTypeRefOrd) (** Evaluation context *) type eval_ctx = { @@ -337,25 +241,10 @@ type eval_ctx = { (** The map from const generic vars to their values. Those values can be symbolic values or concrete values (in the latter case: if we run in interpreter mode) *) - norm_trait_etypes : ety ETraitTypeRefMap.t; + norm_trait_types : ty TraitTypeRefMap.t; (** The normalized trait types (a map from trait types to their representatives). - Note that this doesn't support account higher-order types. *) - norm_trait_rtypes : rty RTraitTypeRefMap.t; - (** We need this because we manipulate two kinds of types. - Note that we actually forbid regions from appearing both in the trait - references and in the constraints given to the associated types, - meaning that we don't have to worry about mismatches due to changes - in region ids. - - TODO: how not to duplicate? - *) - norm_trait_stypes : sty STraitTypeRefMap.t; - (** We sometimes need to normalize types in non-instantiated signatures. - - Note that we either need to use the etypes/rtypes maps, or the stypes map. - This means that we either compute the maps for etypes and rtypes, or compute - the one for stypes (we don't always compute and carry all the maps). - *) + Note that this doesn't take into account higher-order type constraints + (of the shape `for<'a> ...`). *) env : env; ended_regions : RegionId.Set.t; } @@ -389,10 +278,10 @@ let env_lookup_var (env : env) (vid : VarId.id) : var_binder * typed_value = match env with | [] -> raise (Invalid_argument ("Variable not found: " ^ VarId.to_string vid)) - | Var (VarBinder var, v) :: env' -> + | EBinding (BVar var, v) :: env' -> if var.index = vid then (var, v) else lookup env' - | (Var (DummyBinder _, _) | Abs _) :: env' -> lookup env' - | Frame :: _ -> raise (Failure "End of frame") + | (EBinding (BDummy _, _) | EAbs _) :: env' -> lookup env' + | EFrame :: _ -> raise (Failure "End of frame") in lookup env @@ -440,11 +329,11 @@ let env_update_var_value (env : env) (vid : VarId.id) (nv : typed_value) : env = let rec update env = match env with | [] -> raise (Failure "Unexpected") - | Var ((VarBinder b as var), v) :: env' -> - if b.index = vid then Var (var, nv) :: env' - else Var (var, v) :: update env' - | ((Var (DummyBinder _, _) | Abs _) as ee) :: env' -> ee :: update env' - | Frame :: _ -> raise (Failure "End of frame") + | EBinding ((BVar b as var), v) :: env' -> + if b.index = vid then EBinding (var, nv) :: env' + else EBinding (var, v) :: update env' + | ((EBinding (BDummy _, _) | EAbs _) as ee) :: env' -> ee :: update env' + | EFrame :: _ -> raise (Failure "End of frame") in update env @@ -466,9 +355,9 @@ let ctx_update_var_value (ctx : eval_ctx) (vid : VarId.id) (nv : typed_value) : is important). *) let ctx_push_var (ctx : eval_ctx) (var : var) (v : typed_value) : eval_ctx = - assert (var.var_ty = v.ty); + assert (TypesUtils.ty_is_ety var.var_ty && var.var_ty = v.ty); let bv = var_to_binder var in - { ctx with env = Var (VarBinder bv, v) :: ctx.env } + { ctx with env = EBinding (BVar bv, v) :: ctx.env } (** Push a list of variables. @@ -488,11 +377,12 @@ let ctx_push_vars (ctx : eval_ctx) (vars : (var * typed_value) list) : eval_ctx vars))); assert ( List.for_all - (fun (var, (value : typed_value)) -> var.var_ty = value.ty) + (fun (var, (value : typed_value)) -> + TypesUtils.ty_is_ety var.var_ty && var.var_ty = value.ty) vars); let vars = List.map - (fun (var, value) -> Var (VarBinder (var_to_binder var), value)) + (fun (var, value) -> EBinding (BVar (var_to_binder var), value)) vars in let vars = List.rev vars in @@ -501,7 +391,7 @@ let ctx_push_vars (ctx : eval_ctx) (vars : (var * typed_value) list) : eval_ctx (** Push a dummy variable in the context's environment. *) let ctx_push_dummy_var (ctx : eval_ctx) (vid : DummyVarId.id) (v : typed_value) : eval_ctx = - { ctx with env = Var (DummyBinder vid, v) :: ctx.env } + { ctx with env = EBinding (BDummy vid, v) :: ctx.env } (** Remove a dummy variable from a context's environment. *) let ctx_remove_dummy_var (ctx : eval_ctx) (vid : DummyVarId.id) : @@ -509,7 +399,7 @@ let ctx_remove_dummy_var (ctx : eval_ctx) (vid : DummyVarId.id) : let rec remove_var (env : env) : env * typed_value = match env with | [] -> raise (Failure "Could not lookup a dummy variable") - | Var (DummyBinder vid', v) :: env when vid' = vid -> (env, v) + | EBinding (BDummy vid', v) :: env when vid' = vid -> (env, v) | ee :: env -> let env, v = remove_var env in (ee :: env, v) @@ -522,27 +412,36 @@ let ctx_lookup_dummy_var (ctx : eval_ctx) (vid : DummyVarId.id) : typed_value = let rec lookup_var (env : env) : typed_value = match env with | [] -> raise (Failure "Could not lookup a dummy variable") - | Var (DummyBinder vid', v) :: _env when vid' = vid -> v + | EBinding (BDummy vid', v) :: _env when vid' = vid -> v | _ :: env -> lookup_var env in lookup_var ctx.env +let erase_regions (ty : ty) : ty = + let v = + object + inherit [_] map_ty + method! visit_region _ _ = RErased + end + in + v#visit_ty () ty + (** Push an uninitialized variable (which thus maps to {!constructor:Values.value.Bottom}) *) let ctx_push_uninitialized_var (ctx : eval_ctx) (var : var) : eval_ctx = - ctx_push_var ctx var (mk_bottom var.var_ty) + ctx_push_var ctx var (mk_bottom (erase_regions var.var_ty)) (** Push a list of uninitialized variables (which thus map to {!constructor:Values.value.Bottom}) *) let ctx_push_uninitialized_vars (ctx : eval_ctx) (vars : var list) : eval_ctx = - let vars = List.map (fun v -> (v, mk_bottom v.var_ty)) vars in + 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 rec lookup env = match env with | [] -> None - | Var (_, _) :: env' -> lookup env' - | Abs abs :: env' -> if pred abs then Some abs else lookup env' - | Frame :: env' -> lookup env' + | EBinding (_, _) :: env' -> lookup env' + | EAbs abs :: env' -> if pred abs then Some abs else lookup env' + | EFrame :: env' -> lookup env' in lookup env @@ -558,17 +457,17 @@ let env_remove_abs (env : env) (abs_id : V.AbstractionId.id) : let rec remove (env : env) : env * V.abs option = match env with | [] -> raise (Failure "Unreachable") - | Frame :: _ -> (env, None) - | Var (bv, v) :: env -> + | EFrame :: _ -> (env, None) + | EBinding (bv, v) :: env -> let env, abs_opt = remove env in - (Var (bv, v) :: env, abs_opt) - | Abs abs :: env -> + (EBinding (bv, v) :: env, abs_opt) + | EAbs abs :: env -> if abs.abs_id = abs_id then (env, Some abs) else let env, abs_opt = remove env in (* Update the parents set *) let parents = V.AbstractionId.Set.remove abs_id abs.parents in - (Abs { abs with V.parents } :: env, abs_opt) + (EAbs { abs with V.parents } :: env, abs_opt) in remove env @@ -584,12 +483,12 @@ let env_subst_abs (env : env) (abs_id : V.AbstractionId.id) (nabs : V.abs) : let rec update (env : env) : env * V.abs option = match env with | [] -> raise (Failure "Unreachable") - | Frame :: _ -> (* We're done *) (env, None) - | Var (bv, v) :: env -> + | EFrame :: _ -> (* We're done *) (env, None) + | EBinding (bv, v) :: env -> let env, opt_abs = update env in - (Var (bv, v) :: env, opt_abs) - | Abs abs :: env -> - if abs.abs_id = abs_id then (Abs nabs :: env, Some abs) + (EBinding (bv, v) :: env, opt_abs) + | EAbs abs :: env -> + if abs.abs_id = abs_id then (EAbs nabs :: env, Some abs) else let env, opt_abs = update env in (* Update the parents set *) @@ -600,7 +499,7 @@ let env_subst_abs (env : env) (abs_id : V.AbstractionId.id) (nabs : V.abs) : V.AbstractionId.Set.add nabs.abs_id parents else parents in - (Abs { abs with V.parents } :: env, opt_abs) + (EAbs { abs with V.parents } :: env, opt_abs) in update env @@ -641,7 +540,7 @@ class ['self] iter_frame = fun acc env -> match env with | [] -> () - | Frame :: _ -> (* We stop here *) () + | EFrame :: _ -> (* We stop here *) () | em :: env -> self#visit_env_elem acc em; self#visit_env acc env @@ -656,7 +555,7 @@ class ['self] map_frame_concrete = fun acc env -> match env with | [] -> [] - | Frame :: env -> (* We stop here *) Frame :: env + | EFrame :: env -> (* We stop here *) EFrame :: env | em :: env -> let em = self#visit_env_elem acc em in let env = self#visit_env acc env in @@ -686,17 +585,17 @@ class ['self] map_eval_ctx = let env_iter_abs (f : V.abs -> unit) (env : env) : unit = List.iter (fun (ee : env_elem) -> - match ee with Var _ | Frame -> () | Abs abs -> f abs) + match ee with EBinding _ | EFrame -> () | EAbs abs -> f abs) env let env_map_abs (f : V.abs -> V.abs) (env : env) : env = List.map (fun (ee : env_elem) -> - match ee with Var _ | Frame -> ee | Abs abs -> Abs (f abs)) + match ee with EBinding _ | EFrame -> ee | EAbs abs -> EAbs (f abs)) env let env_filter_abs (f : V.abs -> bool) (env : env) : env = List.filter (fun (ee : env_elem) -> - match ee with Var _ | Frame -> true | Abs abs -> f abs) + match ee with EBinding _ | EFrame -> true | EAbs abs -> f abs) env diff --git a/compiler/Extract.ml b/compiler/Extract.ml index d04f5c1da..24999c7d9 100644 --- a/compiler/Extract.ml +++ b/compiler/Extract.ml @@ -51,7 +51,7 @@ let extract_fun_decl_register_names (ctx : extraction_ctx) (fun ctx (f : fun_decl) -> let open ExtractBuiltin in let fun_id = - (Pure.FunId (Regular f.def_id), f.loop_id, f.back_id) + (Pure.FunId (FRegular f.def_id), f.loop_id, f.back_id) in let fun_info = List.find_opt @@ -124,7 +124,7 @@ let extract_adt_g_value (inside : bool) (variant_id : VariantId.id option) (field_values : 'v list) (ty : ty) : extraction_ctx = match ty with - | Adt (Tuple, generics) -> + | TAdt (Tuple, generics) -> (* Tuple *) (* For now, we only support fully applied tuple constructors *) assert (List.length generics.types = List.length field_values); @@ -146,7 +146,7 @@ let extract_adt_g_value in F.pp_print_string fmt ")"; ctx) - | Adt (adt_id, _) -> + | TAdt (adt_id, _) -> (* "Regular" ADT *) (* If we are generating a pattern for a let-binding and we target Lean, @@ -178,7 +178,7 @@ let extract_adt_g_value | Some vid -> ( (* In the case of Lean, we might have to add the type name as a prefix *) match (!backend, adt_id) with - | Lean, Assumed _ -> + | Lean, TAssumed _ -> ctx_get_type adt_id ctx ^ "." ^ ctx_get_variant adt_id vid ctx | _ -> ctx_get_variant adt_id vid ctx) | None -> ctx_get_struct adt_id ctx @@ -441,7 +441,7 @@ and extract_function_call (ctx : extraction_ctx) (fmt : F.formatter) (* Provided method: we see it as a regular function call, and use the function name *) let fun_id = - FromLlbc (FunId (Regular method_id.id), lp_id, rg_id) + FromLlbc (FunId (FRegular method_id.id), lp_id, rg_id) in let fun_name = ctx_get_function fun_id ctx in F.pp_print_string fmt fun_name; @@ -467,7 +467,7 @@ and extract_function_call (ctx : extraction_ctx) (fmt : F.formatter) *) let types = match fun_id with - | FromLlbc (FunId (Regular id), _, _) -> + | FromLlbc (FunId (FRegular id), _, _) -> fun_builtin_filter_types id generics.types ctx | _ -> Result.Ok generics.types in @@ -506,7 +506,7 @@ and extract_function_call (ctx : extraction_ctx) (fmt : F.formatter) and extract_adt_cons (ctx : extraction_ctx) (fmt : F.formatter) (inside : bool) (adt_cons : adt_cons_id) (generics : generic_args) (args : texpression list) : unit = - let e_ty = Adt (adt_cons.adt_id, generics) in + let e_ty = TAdt (adt_cons.adt_id, generics) in let is_single_pat = false in let _ = extract_adt_g_value @@ -966,7 +966,7 @@ and extract_StructUpdate (ctx : extraction_ctx) (fmt : F.formatter) if need_paren then F.pp_print_string fmt ")"; print_bracket false orb; F.pp_close_box fmt () - | Assumed Array -> + | TAssumed Array -> (* Open the boxes *) F.pp_open_hvbox fmt ctx.indent_incr; let need_paren = inside in @@ -974,7 +974,7 @@ and extract_StructUpdate (ctx : extraction_ctx) (fmt : F.formatter) (* Open the box for `Array.replicate T N [` *) F.pp_open_hovbox fmt ctx.indent_incr; (* Print the array constructor *) - let cs = ctx_get_struct (Assumed Array) ctx in + let cs = ctx_get_struct (TAssumed Array) ctx in F.pp_print_string fmt cs; (* Print the parameters *) let _, generics = ty_as_adt e_ty in @@ -1286,7 +1286,7 @@ let extract_fun_comment (ctx : extraction_ctx) (fmt : F.formatter) (def : fun_decl) : unit = let { keep_fwd; num_backs } = PureUtils.RegularFunIdMap.find - (Pure.FunId (Regular def.def_id), def.loop_id, def.back_id) + (Pure.FunId (FRegular def.def_id), def.loop_id, def.back_id) ctx.fun_name_info in let comment_pre = "[" ^ Print.fun_name_to_string def.basename ^ "]: " in @@ -1772,7 +1772,7 @@ let extract_global_decl (ctx : extraction_ctx) (fmt : F.formatter) let decl_name = ctx_get_global global.def_id ctx in let body_name = ctx_get_function - (FromLlbc (Pure.FunId (Regular global.body_id), None, None)) + (FromLlbc (Pure.FunId (FRegular global.body_id), None, None)) ctx in @@ -2662,7 +2662,7 @@ let extract_unit_test_if_unit_fun (ctx : extraction_ctx) (fmt : F.formatter) F.pp_print_space fmt (); F.pp_print_string fmt "="; F.pp_print_space fmt (); - let success = ctx_get_variant (Assumed Result) result_return_id ctx in + let success = ctx_get_variant (TAssumed Result) result_return_id ctx in F.pp_print_string fmt (success ^ " ())") | Coq -> F.pp_print_string fmt "Check"; @@ -2691,7 +2691,7 @@ let extract_unit_test_if_unit_fun (ctx : extraction_ctx) (fmt : F.formatter) F.pp_print_space fmt (); F.pp_print_string fmt "=="; F.pp_print_space fmt (); - let success = ctx_get_variant (Assumed Result) result_return_id ctx in + let success = ctx_get_variant (TAssumed Result) result_return_id ctx in F.pp_print_string fmt ("." ^ success ^ " ())") | HOL4 -> F.pp_print_string fmt "val _ = assert_return ("; diff --git a/compiler/ExtractBase.ml b/compiler/ExtractBase.ml index 31b1a4472..272e63966 100644 --- a/compiler/ExtractBase.ml +++ b/compiler/ExtractBase.ml @@ -3,7 +3,7 @@ open Pure open TranslateCore module C = Contexts -module RegionVarId = T.RegionVarId +module RegionId = T.RegionId module F = Format open ExtractBuiltin @@ -675,7 +675,7 @@ let id_to_string (id : id) (ctx : extraction_ctx) : string = | AdtId id -> let def = TypeDeclId.Map.find id type_decls in Print.name_to_string def.name - | Assumed aty -> show_assumed_ty aty + | TAssumed aty -> show_assumed_ty aty | Tuple -> raise (Failure "Unreachable") in match id with @@ -687,10 +687,10 @@ let id_to_string (id : id) (ctx : extraction_ctx) : string = | FromLlbc (fid, lp_id, rg_id) -> let fun_name = match fid with - | FunId (Regular fid) -> + | FunId (FRegular fid) -> Print.fun_name_to_string (A.FunDeclId.Map.find fid fun_decls).name - | FunId (Assumed aid) -> A.show_assumed_fun_id aid + | 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") @@ -716,9 +716,9 @@ let id_to_string (id : id) (ctx : extraction_ctx) : string = | DecreasesProofId (fid, lid) -> let fun_name = match fid with - | Regular fid -> + | FRegular fid -> Print.fun_name_to_string (A.FunDeclId.Map.find fid fun_decls).name - | Assumed aid -> A.show_assumed_fun_id aid + | FAssumed aid -> A.show_assumed_fun_id aid in let loop = match lid with @@ -729,9 +729,9 @@ let id_to_string (id : id) (ctx : extraction_ctx) : string = | TerminationMeasureId (fid, lid) -> let fun_name = match fid with - | Regular fid -> + | FRegular fid -> Print.fun_name_to_string (A.FunDeclId.Map.find fid fun_decls).name - | Assumed aid -> A.show_assumed_fun_id aid + | FAssumed aid -> A.show_assumed_fun_id aid in let loop = match lid with @@ -745,19 +745,19 @@ let id_to_string (id : id) (ctx : extraction_ctx) : string = let variant_name = match id with | Tuple -> raise (Failure "Unreachable") - | Assumed Result -> + | TAssumed Result -> if variant_id = result_return_id then "@result::Return" else if variant_id = result_fail_id then "@result::Fail" else raise (Failure "Unreachable") - | Assumed Error -> + | TAssumed Error -> 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") - | Assumed Fuel -> + | TAssumed Fuel -> if variant_id = fuel_zero_id then "@fuel::0" else if variant_id = fuel_succ_id then "@fuel::Succ" else raise (Failure "Unreachable") - | Assumed (State | Array | Slice | Str | RawPtr _) -> + | TAssumed (State | Array | Slice | Str | RawPtr _) -> raise (Failure ("Unreachable: variant id (" @@ -776,7 +776,7 @@ let id_to_string (id : id) (ctx : extraction_ctx) : string = let field_name = match id with | Tuple -> raise (Failure "Unreachable") - | Assumed + | TAssumed (State | Result | Error | Fuel | Array | Slice | Str | RawPtr _) -> (* We can't directly have access to the fields of those types *) raise (Failure "Unreachable") @@ -835,7 +835,7 @@ let allow_collisions (id : id) : bool = | FieldId _ | TraitItemClauseId _ | TraitParentClauseId _ | TraitItemId _ | TraitMethodId _ -> !Config.record_fields_short_names - | FunId (Pure _ | FromLlbc (FunId (Assumed _), _, _)) -> + | FunId (Pure _ | FromLlbc (FunId (FAssumed _), _, _)) -> (* We map several assumed functions to the same id *) true | _ -> false @@ -928,16 +928,16 @@ let ctx_get (id : id) (ctx : extraction_ctx) : string = let names_maps_add_assumed_type (id_to_string : id -> string) (id : assumed_ty) (name : string) (nm : names_maps) : names_maps = - names_maps_add id_to_string (TypeId (Assumed id)) name nm + names_maps_add id_to_string (TypeId (TAssumed id)) name nm let names_maps_add_assumed_struct (id_to_string : id -> string) (id : assumed_ty) (name : string) (nm : names_maps) : names_maps = - names_maps_add id_to_string (StructId (Assumed id)) name nm + names_maps_add id_to_string (StructId (TAssumed id)) name nm let names_maps_add_assumed_variant (id_to_string : id -> string) (id : assumed_ty) (variant_id : VariantId.id) (name : string) (nm : names_maps) : names_maps = - names_maps_add id_to_string (VariantId (Assumed id, variant_id)) name nm + names_maps_add id_to_string (VariantId (TAssumed id, variant_id)) name nm let names_maps_add_function (id_to_string : id -> string) (fid : fun_id) (name : string) (nm : names_maps) : names_maps = @@ -951,7 +951,7 @@ let ctx_get_function (id : fun_id) (ctx : extraction_ctx) : string = let ctx_get_local_function (id : A.FunDeclId.id) (lp : LoopId.id option) (rg : RegionGroupId.id option) (ctx : extraction_ctx) : string = - ctx_get_function (FromLlbc (FunId (Regular id), lp, rg)) ctx + ctx_get_function (FromLlbc (FunId (FRegular id), lp, rg)) ctx let ctx_get_type (id : type_id) (ctx : extraction_ctx) : string = assert (id <> Tuple); @@ -961,7 +961,7 @@ let ctx_get_local_type (id : TypeDeclId.id) (ctx : extraction_ctx) : string = ctx_get_type (AdtId id) ctx let ctx_get_assumed_type (id : assumed_ty) (ctx : extraction_ctx) : string = - ctx_get_type (Assumed id) ctx + ctx_get_type (TAssumed id) ctx let ctx_get_trait_constructor (id : trait_decl_id) (ctx : extraction_ctx) : string = @@ -1027,11 +1027,11 @@ let ctx_get_variant (def_id : type_id) (variant_id : VariantId.id) let ctx_get_decreases_proof (def_id : A.FunDeclId.id) (loop_id : LoopId.id option) (ctx : extraction_ctx) : string = - ctx_get (DecreasesProofId (Regular def_id, loop_id)) ctx + ctx_get (DecreasesProofId (FRegular def_id, loop_id)) ctx let ctx_get_termination_measure (def_id : A.FunDeclId.id) (loop_id : LoopId.id option) (ctx : extraction_ctx) : string = - ctx_get (TerminationMeasureId (Regular def_id, loop_id)) ctx + ctx_get (TerminationMeasureId (FRegular def_id, loop_id)) ctx (** Generate a unique type variable name and add it to the context *) let ctx_add_type_var (basename : string) (id : TypeVarId.id) @@ -1150,7 +1150,7 @@ let ctx_add_decreases_proof (def : fun_decl) (ctx : extraction_ctx) : ctx.fmt.decreases_proof_name def.def_id def.basename def.num_loops def.loop_id in - ctx_add (DecreasesProofId (Regular def.def_id, def.loop_id)) name ctx + ctx_add (DecreasesProofId (FRegular def.def_id, def.loop_id)) name ctx let ctx_add_termination_measure (def : fun_decl) (ctx : extraction_ctx) : extraction_ctx = @@ -1158,7 +1158,7 @@ let ctx_add_termination_measure (def : fun_decl) (ctx : extraction_ctx) : ctx.fmt.termination_measure_name def.def_id def.basename def.num_loops def.loop_id in - ctx_add (TerminationMeasureId (Regular def.def_id, def.loop_id)) name ctx + ctx_add (TerminationMeasureId (FRegular def.def_id, def.loop_id)) name ctx let ctx_add_global_decl_and_body (def : A.global_decl) (ctx : extraction_ctx) : extraction_ctx = @@ -1176,7 +1176,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 (Regular def.body_id), None, None)) in + let body = FunId (FromLlbc (FunId (FRegular def.body_id), None, None)) in let ctx = ctx_add decl (name ^ "_c") ctx in let ctx = ctx_add body (name ^ "_body") ctx in ctx @@ -1197,7 +1197,7 @@ let ctx_compute_fun_name (trans_group : pure_fun_translation) (def : fun_decl) let rg = T.RegionGroupId.nth sg.regions_hierarchy rg_id in let region_names = List.map - (fun rid -> (T.RegionVarId.nth sg.generics.regions rid).name) + (fun rid -> (T.RegionId.nth sg.generics.regions rid).name) rg.regions in Some { id = rg_id; region_names } @@ -1218,7 +1218,7 @@ let ctx_add_fun_decl (trans_group : pure_fun_translation) (def : fun_decl) let num_backs = List.length backs in (* Add the function name *) let def_name = ctx_compute_fun_name trans_group def ctx in - let fun_id = (Pure.FunId (Regular def_id), def.loop_id, def.back_id) in + let fun_id = (Pure.FunId (FRegular def_id), def.loop_id, def.back_id) in let ctx = ctx_add (FunId (FromLlbc fun_id)) def_name ctx in (* Add the name info *) { @@ -1300,7 +1300,7 @@ let initialize_names_maps (fmt : formatter) (init : names_map_init) : names_maps let assumed_functions = List.map (fun (fid, rg, name) -> - (FromLlbc (Pure.FunId (Assumed fid), None, rg), name)) + (FromLlbc (Pure.FunId (FAssumed fid), None, rg), name)) init.assumed_llbc_functions @ List.map (fun (fid, name) -> (Pure fid, name)) init.assumed_pure_functions in diff --git a/compiler/ExtractTypes.ml b/compiler/ExtractTypes.ml index 77f76bb41..482730231 100644 --- a/compiler/ExtractTypes.ml +++ b/compiler/ExtractTypes.ml @@ -799,19 +799,19 @@ let mk_formatter (ctx : trans_ctx) (crate_name : string) | None -> ( (* No basename: we use the first letter of the type *) match ty with - | Adt (type_id, generics) -> ( + | TAdt (type_id, generics) -> ( match type_id with | Tuple -> (* The "pair" case is frequent enough to have its special treatment *) if List.length generics.types = 2 then "p" else "t" - | Assumed Result -> "r" - | Assumed Error -> ConstStrings.error_basename - | Assumed Fuel -> ConstStrings.fuel_basename - | Assumed Array -> "a" - | Assumed Slice -> "s" - | Assumed Str -> "s" - | Assumed State -> ConstStrings.state_basename - | Assumed (RawPtr _) -> "p" + | TAssumed Result -> "r" + | TAssumed Error -> ConstStrings.error_basename + | TAssumed Fuel -> ConstStrings.fuel_basename + | TAssumed Array -> "a" + | TAssumed Slice -> "s" + | TAssumed Str -> "s" + | TAssumed State -> ConstStrings.state_basename + | TAssumed (RawPtr _) -> "p" | AdtId adt_id -> let def = TypeDeclId.Map.find adt_id ctx.type_ctx.type_decls in (* Derive the var name from the last ident of the type name @@ -826,8 +826,8 @@ let mk_formatter (ctx : trans_ctx) (crate_name : string) match !backend with | FStar -> "x" (* lacking inspiration here... *) | Coq | Lean | HOL4 -> "t" (* lacking inspiration here... *)) - | Literal lty -> ( - match lty with Bool -> "b" | Char -> "c" | Integer _ -> "i") + | TLiteral lty -> ( + match lty with TBool -> "b" | TChar -> "c" | TInteger _ -> "i") | Arrow _ -> "f" | TraitType (_, _, name) -> name_from_type_ident name) in @@ -864,7 +864,7 @@ let mk_formatter (ctx : trans_ctx) (crate_name : string) let extract_literal (fmt : F.formatter) (inside : bool) (cv : literal) : unit = match cv with - | Scalar sv -> ( + | VScalar sv -> ( match !backend with | FStar -> F.pp_print_string fmt (Z.to_string sv.PV.value) | Coq | HOL4 | Lean -> @@ -895,14 +895,14 @@ let mk_formatter (ctx : trans_ctx) (crate_name : string) | HOL4 -> () | _ -> raise (Failure "Unreachable")); if print_brackets then F.pp_print_string fmt ")") - | Bool b -> + | VBool b -> let b = match !backend with | HOL4 -> if b then "T" else "F" | Coq | FStar | Lean -> if b then "true" else "false" in F.pp_print_string fmt b - | Char c -> ( + | VChar c -> ( match !backend with | HOL4 -> (* [#"a"] is a notation for [CHR 97] (97 is the ASCII code for 'a') *) @@ -1130,9 +1130,9 @@ let extract_const_generic (ctx : extraction_ctx) (fmt : F.formatter) let extract_literal_type (ctx : extraction_ctx) (fmt : F.formatter) (ty : literal_type) : unit = match ty with - | Bool -> F.pp_print_string fmt ctx.fmt.bool_name - | Char -> F.pp_print_string fmt ctx.fmt.char_name - | Integer int_ty -> F.pp_print_string fmt (ctx.fmt.int_name int_ty) + | TBool -> F.pp_print_string fmt ctx.fmt.bool_name + | TChar -> F.pp_print_string fmt ctx.fmt.char_name + | TInteger int_ty -> F.pp_print_string fmt (ctx.fmt.int_name int_ty) (** [inside] constrols whether we should add parentheses or not around type applications (if [true] we add parentheses). @@ -1158,7 +1158,7 @@ let rec extract_ty (ctx : extraction_ctx) (fmt : F.formatter) (no_params_tys : TypeDeclId.Set.t) (inside : bool) (ty : ty) : unit = let extract_rec = extract_ty ctx fmt no_params_tys in match ty with - | Adt (type_id, generics) -> ( + | TAdt (type_id, generics) -> ( let has_params = generics <> empty_generic_args in match type_id with | Tuple -> @@ -1181,7 +1181,7 @@ let rec extract_ty (ctx : extraction_ctx) (fmt : F.formatter) F.pp_print_space fmt ()) (extract_rec true) generics.types; F.pp_print_string fmt ")") - | AdtId _ | Assumed _ -> ( + | AdtId _ | TAssumed _ -> ( (* HOL4 behaves differently. Where in Coq/FStar/Lean we would write: `tree a b` @@ -1224,7 +1224,7 @@ let rec extract_ty (ctx : extraction_ctx) (fmt : F.formatter) let print_tys = match type_id with | AdtId id -> not (TypeDeclId.Set.mem id no_params_tys) - | Assumed _ -> true + | TAssumed _ -> true | _ -> raise (Failure "Unreachable") in if types <> [] && print_tys then ( @@ -1244,7 +1244,7 @@ let rec extract_ty (ctx : extraction_ctx) (fmt : F.formatter) (extract_trait_ref ctx fmt no_params_tys true) trait_refs))) | TypeVar vid -> F.pp_print_string fmt (ctx_get_type_var vid ctx) - | Literal lty -> extract_literal_type ctx fmt lty + | TLiteral lty -> extract_literal_type ctx fmt lty | Arrow (arg_ty, ret_ty) -> if inside then F.pp_print_string fmt "("; extract_rec false arg_ty; diff --git a/compiler/FunsAnalysis.ml b/compiler/FunsAnalysis.ml index e17ea16f5..1f17c1aaa 100644 --- a/compiler/FunsAnalysis.ml +++ b/compiler/FunsAnalysis.ml @@ -91,7 +91,7 @@ let analyze_module (m : crate) (funs_map : fun_decl FunDeclId.Map.t) method! visit_Call env call = (match call.func.func with - | FunId (Regular id) -> + | FunId (FRegular id) -> if FunDeclId.Set.mem id fun_ids then ( can_diverge := true; is_rec := true) @@ -100,7 +100,7 @@ let analyze_module (m : crate) (funs_map : fun_decl FunDeclId.Map.t) self#may_fail info.can_fail; stateful := !stateful || info.stateful; can_diverge := !can_diverge || info.can_diverge - | FunId (Assumed id) -> + | FunId (FAssumed id) -> (* None of the assumed functions can diverge nor are considered stateful *) can_fail := !can_fail || Assumed.assumed_fun_can_fail id | TraitMethod _ -> diff --git a/compiler/Interpreter.ml b/compiler/Interpreter.ml index 24ff4808f..bc28bcd6b 100644 --- a/compiler/Interpreter.ml +++ b/compiler/Interpreter.ml @@ -46,7 +46,7 @@ let normalize_inst_fun_sig (ctx : C.eval_ctx) (sg : A.inst_fun_sig) : let { A.regions_hierarchy = _; trait_type_constraints = _; inputs; output } = sg in - let norm = AssociatedTypes.ctx_normalize_rty ctx 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 } @@ -70,7 +70,7 @@ let symbolic_instantiate_fun_sig (ctx : C.eval_ctx) (sg : A.fun_sig) in let generics = let { T.regions; types; const_generics; trait_clauses } = sg.generics in - let regions = List.map (fun _ -> T.Erased) regions in + let regions = List.map (fun _ -> T.RErased) regions in let types = List.map (fun (v : T.type_var) -> T.TypeVar v.T.index) types in let const_generics = List.map @@ -110,9 +110,8 @@ 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.erased_region T.trait_instance_id T.TraitClauseId.Map.t) - clause_id : T.erased_region T.trait_instance_id = + 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 | Some tr -> tr | None -> raise (Failure "Local trait clause not found") @@ -185,7 +184,7 @@ let initialize_symbolic_context_for_fun (ctx : C.decls_ctx) (fdef : A.fun_decl) let sg = fdef.signature in (* Create the context *) let region_groups = - List.map (fun (g : T.region_var_group) -> g.id) sg.regions_hierarchy + List.map (fun (g : T.region_group) -> g.id) sg.regions_hierarchy in let ctx = initialize_eval_context ctx region_groups sg.generics.types diff --git a/compiler/InterpreterBorrows.ml b/compiler/InterpreterBorrows.ml index e97795a19..d4dbf80a0 100644 --- a/compiler/InterpreterBorrows.ml +++ b/compiler/InterpreterBorrows.ml @@ -301,8 +301,8 @@ let give_back_value (config : C.config) (bid : V.BorrowId.id) if nv.V.ty <> expected_ty then ( log#serror ("give_back_value: improper type:\n- expected: " - ^ ety_to_string ctx ty ^ "\n- received: " - ^ ety_to_string ctx nv.V.ty); + ^ PA.ty_to_string ctx ty ^ "\n- received: " + ^ PA.ty_to_string ctx nv.V.ty); raise (Failure "Value given back doesn't have the proper type")); (* Replace *) set_replaced (); @@ -426,12 +426,12 @@ let give_back_value (config : C.config) (bid : V.BorrowId.id) (* Nothing special to do *) super#visit_ALoan opt_abs lc - method! visit_Abs opt_abs abs = + method! visit_EAbs opt_abs abs = (* We remember in which abstraction we are before diving - * this is necessary for projecting values: we need to know * over which regions to project *) assert (Option.is_none opt_abs); - super#visit_Abs (Some abs) abs + super#visit_EAbs (Some abs) abs end in @@ -447,7 +447,7 @@ let give_back_symbolic_value (_config : C.config) (proj_regions : T.RegionId.Set.t) (proj_ty : T.rty) (sv : V.symbolic_value) (nsv : V.symbolic_value) (ctx : C.eval_ctx) : C.eval_ctx = (* Sanity checks *) - assert (sv.sv_id <> nsv.sv_id); + assert (sv.sv_id <> nsv.sv_id && ty_is_rty proj_ty); (match nsv.sv_kind with | V.SynthInputGivenBack | SynthRetGivenBack | FunCallGivenBack | LoopGivenBack -> @@ -554,8 +554,8 @@ let give_back_avalue_to_same_abstraction (_config : C.config) if nv.V.ty <> expected_ty then ( log#serror ("give_back_avalue_to_same_abstraction: improper type:\n\ - - expected: " ^ rty_to_string ctx ty ^ "\n- received: " - ^ rty_to_string ctx nv.V.ty); + - expected: " ^ PA.ty_to_string ctx ty ^ "\n- received: " + ^ PA.ty_to_string ctx nv.V.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 @@ -1734,14 +1734,14 @@ let destructure_abs (abs_kind : V.abs_kind) (can_end : bool) and list_values (v : V.typed_value) : V.typed_avalue list * V.typed_value = let ty = v.V.ty in match v.V.value with - | Literal _ -> ([], v) - | Adt adt -> + | VLiteral _ -> ([], v) + | VAdt adt -> let avll, field_values = List.split (List.map list_values adt.field_values) in let avl = List.concat avll in let adt = { adt with V.field_values } in - (avl, { v with V.value = Adt adt }) + (avl, { v with V.value = VAdt adt }) | Bottom -> raise (Failure "Unreachable") | Borrow _ -> (* We don't support nested borrows for now *) @@ -1750,9 +1750,9 @@ let destructure_abs (abs_kind : V.abs_kind) (can_end : bool) match lc with | SharedLoan (bids, sv) -> let avl, sv = list_values sv in - if destructure_shared_values then + if destructure_shared_values then ( (* Rem.: the shared value can't contain loans nor borrows *) - let rty = ety_no_regions_to_rty ty in + assert (ty_no_regions ty); let av : V.typed_avalue = assert (not (value_has_loans_or_borrows ctx sv.V.value)); (* We introduce fresh ids for the symbolic values *) @@ -1771,12 +1771,12 @@ let destructure_abs (abs_kind : V.abs_kind) (can_end : bool) let sv = mk_value_with_fresh_sids sv in (* Create the new avalue *) let value = - V.ALoan (V.ASharedLoan (bids, sv, mk_aignored rty)) + V.ALoan (V.ASharedLoan (bids, sv, mk_aignored ty)) in - { V.value; ty = rty } + { V.value; ty } in let avl = List.append [ av ] avl in - (avl, sv) + (avl, sv)) else (avl, { v with V.value = V.Loan (V.SharedLoan (bids, sv)) }) | MutLoan _ -> raise (Failure "Unreachable")) | Symbolic _ -> @@ -1842,12 +1842,12 @@ let convert_value_to_abstractions (abs_kind : V.abs_kind) (can_end : bool) let ty = v.V.ty in match v.V.value with - | V.Literal _ -> ([], v) + | V.VLiteral _ -> ([], v) | V.Bottom -> (* Can happen: we *do* convert dummy values to abstractions, and dummy values can contain bottoms *) ([], v) - | V.Adt adt -> + | V.VAdt adt -> (* Two cases, depending on whether we have to group all the borrows/loans inside one abstraction or not *) let avl, field_values = @@ -1879,16 +1879,17 @@ let convert_value_to_abstractions (abs_kind : V.abs_kind) (can_end : bool) ([], field_values) in let adt = { adt with field_values } in - (avl, { v with V.value = V.Adt adt }) + (avl, { v with V.value = V.VAdt adt }) | V.Borrow bc -> ( let _, ref_ty, kind = ty_as_ref ty in + assert (ty_no_regions ref_ty); (* Sanity check *) assert allow_borrows; (* Convert the borrow content *) match bc with | SharedBorrow bid -> - let ref_ty = ety_no_regions_to_rty ref_ty in - let ty = T.Ref (T.Var r_id, ref_ty, kind) in + assert (ty_no_regions ref_ty); + let ty = T.Ref (T.RVar r_id, ref_ty, kind) in let value = V.ABorrow (V.ASharedBorrow bid) in ([ { V.value; ty } ], v) | MutBorrow (bid, bv) -> @@ -1896,8 +1897,7 @@ let convert_value_to_abstractions (abs_kind : V.abs_kind) (can_end : bool) (* We don't support nested borrows for now *) assert (not (value_has_borrows ctx bv.V.value)); (* Create an avalue to push - note that we use [AIgnore] for the inner avalue *) - let ref_ty = ety_no_regions_to_rty ref_ty in - let ty = T.Ref (T.Var r_id, ref_ty, kind) in + let ty = T.Ref (T.RVar r_id, ref_ty, kind) in let ignored = mk_aignored ref_ty in let av = V.ABorrow (V.AMutBorrow (bid, ignored)) in let av = { V.value = av; ty } in @@ -1917,8 +1917,8 @@ let convert_value_to_abstractions (abs_kind : V.abs_kind) (can_end : bool) assert (not (value_has_borrows ctx sv.V.value)); (* Push the avalue - note that we use [AIgnore] for the inner avalue *) (* For avalues, a loan has the borrow type *) - let ty = ety_no_regions_to_rty ty in - let ty = mk_ref_ty (T.Var r_id) ty T.Shared in + assert (ty_no_regions ty); + let ty = mk_ref_ty (T.RVar r_id) ty T.Shared 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 @@ -1935,8 +1935,8 @@ let convert_value_to_abstractions (abs_kind : V.abs_kind) (can_end : bool) | V.MutLoan bid -> (* Push the avalue - note that we use [AIgnore] for the inner avalue *) (* For avalues, a loan has the borrow type *) - let ty = ety_no_regions_to_rty ty in - let ty = mk_ref_ty (T.Var r_id) ty T.Mut in + assert (ty_no_regions ty); + let ty = mk_ref_ty (T.RVar r_id) ty T.Mut in let ignored = mk_aignored ty in let av = V.ALoan (V.AMutLoan (bid, ignored)) in let av = { V.value = av; ty } in diff --git a/compiler/InterpreterBorrows.mli b/compiler/InterpreterBorrows.mli index 31b67bd7f..6302dcc38 100644 --- a/compiler/InterpreterBorrows.mli +++ b/compiler/InterpreterBorrows.mli @@ -137,7 +137,6 @@ val convert_value_to_abstractions : Rem.: it may be more idiomatic to have a functor, but this seems a bit heavyweight, though. *) - type merge_duplicates_funcs = { merge_amut_borrows : V.borrow_id -> diff --git a/compiler/InterpreterBorrowsCore.ml b/compiler/InterpreterBorrowsCore.ml index e7da045cd..cf8e59942 100644 --- a/compiler/InterpreterBorrowsCore.ml +++ b/compiler/InterpreterBorrowsCore.ml @@ -88,24 +88,29 @@ let add_borrow_or_abs_id_to_chain (msg : string) (id : borrow_or_abs_id) (** Helper function. This function allows to define in a generic way a comparison of **region types**. - See [projections_interesect] for instance. - + See [projections_intersect] for instance. + + Important: the regions in the types mustn't be erased. + [default]: default boolean to return, when comparing types with no regions [combine]: how to combine booleans [compare_regions]: how to compare regions TODO: is there a way of deriving such a comparison? + TODO: rename *) let rec compare_rtys (default : bool) (combine : bool -> bool -> bool) - (compare_regions : T.RegionId.id T.region -> T.RegionId.id T.region -> bool) - (ty1 : T.rty) (ty2 : T.rty) : bool = + (compare_regions : T.region -> T.region -> bool) (ty1 : T.rty) (ty2 : T.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); (* Normalize the associated types *) match (ty1, ty2) with - | T.Literal lit1, T.Literal lit2 -> + | T.TLiteral lit1, T.TLiteral lit2 -> assert (lit1 = lit2); default - | T.Adt (id1, generics1), T.Adt (id2, generics2) -> + | T.TAdt (id1, generics1), T.TAdt (id2, generics2) -> assert (id1 = id2); (* There are no regions in the const generics, so we ignore them, but we still check they are the same, for sanity *) @@ -161,8 +166,8 @@ let rec compare_rtys (default : bool) (combine : bool -> bool -> bool) | _ -> log#lerror (lazy - ("compare_rtys: unexpected inputs:" ^ "\n- ty1: " ^ T.show_rty ty1 - ^ "\n- ty2: " ^ T.show_rty ty2)); + ("compare_rtys: unexpected inputs:" ^ "\n- ty1: " ^ T.show_ty ty1 + ^ "\n- ty2: " ^ T.show_ty ty2)); raise (Failure "Unreachable") (** Check if two different projections intersect. This is necessary when @@ -183,6 +188,9 @@ let projections_intersect (ty1 : T.rty) (rset1 : T.RegionId.Set.t) (ty2 : T.rty) (** Check if the first projection contains the second projection. We use this function when checking invariants. + + 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 = @@ -264,21 +272,21 @@ let lookup_loan_opt (ek : exploration_kind) (l : V.BorrowId.id) | V.AIgnoredSharedLoan _ -> super#visit_aloan_content env lc - method! visit_Var env bv v = + method! visit_EBinding env bv v = assert (Option.is_none !abs_or_var); abs_or_var := Some (match bv with - | VarBinder b -> VarId b.C.index - | DummyBinder id -> DummyVarId id); - super#visit_Var env bv v; + | BVar b -> VarId b.C.index + | BDummy id -> DummyVarId id); + super#visit_EBinding env bv v; abs_or_var := None - method! visit_Abs env abs = + 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); - super#visit_Abs env abs; + super#visit_EAbs env abs; abs_or_var := None) else () end @@ -921,6 +929,8 @@ let remove_intersecting_aproj_borrows_shared (regions : T.RegionId.Set.t) Note that for sanity, this function checks that we update *at least* one projector of loans. + + [proj_ty]: shouldn't contain erased regions. [subst]: takes as parameters the abstraction in which we perform the substitution and the list of given back values at the projector of @@ -932,6 +942,8 @@ 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 = + (* *) + assert (ty_is_rty proj_ty); (* Small helpers for sanity checks *) let updated = ref false in let update abs local_given_back : V.aproj = diff --git a/compiler/InterpreterExpansion.ml b/compiler/InterpreterExpansion.ml index b267bb514..48688893c 100644 --- a/compiler/InterpreterExpansion.ml +++ b/compiler/InterpreterExpansion.ml @@ -211,11 +211,12 @@ let apply_symbolic_expansion_non_borrow (config : C.config) The function might return a list of values if the symbolic value to expand is an enumeration. + [generics]: mustn't contain erased regions. [expand_enumerations] controls the expansion of enumerations: if false, it 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.rgeneric_args) + (kind : V.sv_kind) (def_id : T.TypeDeclId.id) (generics : T.generic_args) (ctx : C.eval_ctx) : V.symbolic_expansion list = (* Lookup the definition and check if it is an enumeration with several * variants *) @@ -263,11 +264,12 @@ let compute_expanded_symbolic_box_value (kind : V.sv_kind) (boxed_ty : T.rty) : The function might return a list of values if the symbolic value to expand is an enumeration. + [generics]: the regions shouldn't have been erased. [expand_enumerations] controls the expansion of enumerations: if [false], it doesn't allow the expansion of enumerations *containing several variants*. *) let compute_expanded_symbolic_adt_value (expand_enumerations : bool) - (kind : V.sv_kind) (adt_id : T.type_id) (generics : T.rgeneric_args) + (kind : V.sv_kind) (adt_id : T.type_id) (generics : T.generic_args) (ctx : C.eval_ctx) : V.symbolic_expansion list = match (adt_id, generics.regions, generics.types) with | T.AdtId def_id, _, _ -> @@ -275,7 +277,7 @@ let compute_expanded_symbolic_adt_value (expand_enumerations : bool) def_id generics ctx | T.Tuple, [], _ -> [ compute_expanded_symbolic_tuple_value kind generics.types ] - | T.Assumed T.Box, [], [ boxed_ty ] -> + | T.TAssumed T.TBox, [], [ boxed_ty ] -> [ compute_expanded_symbolic_box_value kind boxed_ty ] | _ -> raise @@ -330,10 +332,10 @@ let expand_symbolic_value_shared_borrow (config : C.config) V.Borrow (V.SharedBorrow bid) else super#visit_Symbolic env sv - method! visit_Abs proj_regions abs = + method! visit_EAbs proj_regions abs = assert (Option.is_none proj_regions); let proj_regions = Some abs.V.regions in - super#visit_Abs proj_regions abs + super#visit_EAbs proj_regions abs method! visit_AProjSharedBorrow proj_regions asb = let expand_asb (asb : V.abstract_shared_borrow) : @@ -398,9 +400,9 @@ let expand_symbolic_value_shared_borrow (config : C.config) (** TODO: simplify and merge with the other expansion function *) let expand_symbolic_value_borrow (config : C.config) (original_sv : V.symbolic_value) (original_sv_place : SA.mplace option) - (region : T.RegionId.id T.region) (ref_ty : T.rty) (rkind : T.ref_kind) : - cm_fun = + (region : T.region) (ref_ty : T.rty) (rkind : T.ref_kind) : cm_fun = fun cf ctx -> + assert (region <> T.RErased); (* Check that we are allowed to expand the reference *) assert (not (region_in_set region ctx.ended_regions)); (* Match on the reference kind *) @@ -500,10 +502,10 @@ let expand_symbolic_bool (config : C.config) (sv : V.symbolic_value) let original_sv = sv in let original_sv_place = sv_place in let rty = original_sv.V.sv_ty in - assert (rty = T.Literal PV.Bool); + assert (rty = T.TLiteral PV.TBool); (* Expand the symbolic value to true or false and continue execution *) - let see_true = V.SeLiteral (PV.Bool true) in - let see_false = V.SeLiteral (PV.Bool false) in + let see_true = V.SeLiteral (PV.VBool true) in + let see_false = V.SeLiteral (PV.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 @@ -527,7 +529,7 @@ let expand_symbolic_value_no_branching (config : C.config) fun cf ctx -> match rty with (* ADTs *) - | T.Adt (adt_id, generics) -> + | T.TAdt (adt_id, generics) -> (* Compute the expanded value *) let allow_branching = false in let seel = @@ -584,7 +586,7 @@ let expand_symbolic_adt (config : C.config) (sv : V.symbolic_value) (* Execute *) match rty with (* ADTs *) - | T.Adt (adt_id, generics) -> + | T.TAdt (adt_id, generics) -> let allow_branching = true in (* Compute the expanded value *) let seel = @@ -604,7 +606,7 @@ let expand_symbolic_int (config : C.config) (sv : V.symbolic_value) (tgts : (V.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.Literal (PV.Integer int_type)); + assert (sv.V.sv_ty = T.TLiteral (PV.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 @@ -615,7 +617,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.Scalar v)), cf)) tgts + List.map (fun (v, cf) -> (Some (V.SeLiteral (PV.VScalar v)), cf)) tgts in let seel = List.append seel [ (None, otherwise) ] in (* Then expand and evaluate - this generates the proper symbolic AST *) @@ -663,7 +665,7 @@ let greedy_expand_symbolics_with_borrows (config : C.config) : cm_fun = ^ symbolic_value_to_string ctx sv)); let cc : cm_fun = match sv.V.sv_ty with - | T.Adt (AdtId def_id, _) -> + | T.TAdt (AdtId def_id, _) -> (* {!expand_symbolic_value_no_branching} checks if there are branchings, * but we prefer to also check it here - this leads to cleaner messages * and debugging *) @@ -688,15 +690,15 @@ let greedy_expand_symbolics_with_borrows (config : C.config) : cm_fun = [config]): " ^ Print.name_to_string def.name)) else expand_symbolic_value_no_branching config sv None - | T.Adt ((Tuple | Assumed Box), _) | T.Ref (_, _, _) -> + | T.TAdt ((Tuple | TAssumed TBox), _) | T.Ref (_, _, _) -> (* Ok *) expand_symbolic_value_no_branching config sv None - | T.Adt (Assumed (Array | Slice | Str), _) -> + | T.TAdt (TAssumed (TArray | TSlice | TStr), _) -> (* We can't expand those *) raise (Failure "Attempted to greedily expand an ADT which can't be expanded ") - | T.TypeVar _ | T.Literal _ | Never | T.TraitType _ | T.Arrow _ + | T.TypeVar _ | T.TLiteral _ | Never | T.TraitType _ | T.Arrow _ | T.RawPtr _ -> raise (Failure "Unreachable") in diff --git a/compiler/InterpreterExpressions.ml b/compiler/InterpreterExpressions.ml index 245f3b778..f4430c778 100644 --- a/compiler/InterpreterExpressions.ml +++ b/compiler/InterpreterExpressions.ml @@ -105,13 +105,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.Bool, Bool v -> { V.value = V.Literal (Bool v); ty = T.Literal ty } - | Char, Char v -> { V.value = V.Literal (Char v); ty = T.Literal ty } - | Integer int_ty, PV.Scalar v -> + | 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 -> (* Check the type and the ranges *) assert (int_ty = v.int_ty); assert (check_scalar_value_in_range v); - { V.value = V.Literal (PV.Scalar v); ty = T.Literal ty } + { V.value = V.VLiteral (PV.VScalar v); ty = T.TLiteral ty } (* Remaining cases (invalid) *) | _, _ -> raise (Failure "Improperly typed constant value") @@ -138,17 +138,17 @@ let rec copy_value (allow_adt_copy : bool) (config : C.config) * the fact that we have exhaustive matches below makes very obvious the cases * in which we need to fail *) match v.V.value with - | V.Literal _ -> (ctx, v) - | V.Adt av -> + | V.VLiteral _ -> (ctx, v) + | V.VAdt av -> (* Sanity check *) (match v.V.ty with - | T.Adt (T.Assumed T.Box, _) -> + | T.TAdt (T.TAssumed T.TBox, _) -> raise (Failure "Can't copy an assumed value other than Option") - | T.Adt (T.AdtId _, _) as ty -> + | T.TAdt (T.AdtId _, _) as ty -> assert (allow_adt_copy || ty_is_primitively_copyable ty) - | T.Adt (T.Tuple, _) -> () (* Ok *) - | T.Adt - ( T.Assumed (Slice | T.Array), + | T.TAdt (T.Tuple, _) -> () (* Ok *) + | T.TAdt + ( T.TAssumed (TSlice | T.TArray), { regions = []; types = [ ty ]; @@ -162,7 +162,7 @@ let rec copy_value (allow_adt_copy : bool) (config : C.config) (copy_value allow_adt_copy config) ctx av.field_values in - (ctx, { v with V.value = V.Adt { av with field_values = fields } }) + (ctx, { v with V.value = V.VAdt { av with field_values = fields } }) | V.Bottom -> raise (Failure "Can't copy ⊥") | V.Borrow bc -> ( (* We can only copy shared borrows *) @@ -292,7 +292,7 @@ let eval_operand_no_reorganize (config : C.config) (op : E.operand) List.find (fun (name, _) -> name = const_name) trait_decl.consts in (* Introduce a fresh symbolic value *) - let v = mk_fresh_symbolic_typed_value_from_ety V.TraitConst ty in + let v = mk_fresh_symbolic_typed_value V.TraitConst ty in (* Continue the evaluation *) let e = cf v ctx in (* We have to wrap the generated expression *) @@ -304,7 +304,7 @@ let eval_operand_no_reorganize (config : C.config) (op : E.operand) ( ctx0, None, value_as_symbolic v.value, - SymbolicAst.TraitConstValue + SymbolicAst.VaTraitConstValue (trait_ref, generics, const_name), e )))) | E.CVar vid -> ( @@ -329,7 +329,7 @@ let eval_operand_no_reorganize (config : C.config) (op : E.operand) ( ctx0, None, value_as_symbolic v.value, - SymbolicAst.ConstGenericValue vid, + SymbolicAst.VaConstGenericValue vid, e ))) | E.CFnPtr _ -> raise (Failure "TODO")) | E.Copy p -> @@ -421,21 +421,21 @@ let eval_unary_op_concrete (config : C.config) (unop : E.unop) (op : E.operand) (* Apply the unop *) let apply cf (v : V.typed_value) : m_fun = match (unop, v.V.value) with - | E.Not, V.Literal (Bool b) -> - cf (Ok { v with V.value = V.Literal (Bool (not b)) }) - | E.Neg, V.Literal (PV.Scalar sv) -> ( + | 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 match mk_scalar sv.int_ty i with | Error _ -> cf (Error EPanic) - | Ok sv -> cf (Ok { v with V.value = V.Literal (PV.Scalar sv) })) - | E.Cast (E.CastInteger (src_ty, tgt_ty)), V.Literal (PV.Scalar sv) -> ( + | 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) -> ( assert (src_ty = sv.int_ty); let i = sv.PV.value in match mk_scalar tgt_ty i with | Error _ -> cf (Error EPanic) | Ok sv -> - let ty = T.Literal (Integer tgt_ty) in - let value = V.Literal (PV.Scalar sv) in + let ty = T.TLiteral (TInteger tgt_ty) in + let value = V.VLiteral (PV.VScalar sv) in cf (Ok { V.ty; value })) | _ -> raise (Failure "Invalid input for unop") in @@ -452,9 +452,9 @@ let eval_unary_op_symbolic (config : C.config) (unop : E.unop) (op : E.operand) let res_sv_id = C.fresh_symbolic_value_id () in let res_sv_ty = match (unop, v.V.ty) with - | E.Not, (T.Literal Bool as lty) -> lty - | E.Neg, (T.Literal (Integer _) as lty) -> lty - | E.Cast (E.CastInteger (_, tgt_ty)), _ -> T.Literal (Integer tgt_ty) + | 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) | _ -> raise (Failure "Invalid input for unop") in let res_sv = @@ -489,11 +489,11 @@ 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.Literal (Bool b); ty = T.Literal Bool }) + Ok { V.value = V.VLiteral (VBool b); ty = T.TLiteral TBool }) else (* For the non-equality operations, the input values are necessarily scalars *) match (v1.V.value, v2.V.value) with - | V.Literal (PV.Scalar sv1), V.Literal (PV.Scalar sv2) -> ( + | V.VLiteral (PV.VScalar sv1), V.VLiteral (PV.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 @@ -514,7 +514,7 @@ let eval_binary_op_concrete_compute (binop : E.binop) (v1 : V.typed_value) raise (Failure "Unreachable") in Ok - ({ V.value = V.Literal (Bool b); ty = T.Literal Bool } + ({ 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 -> ( @@ -543,8 +543,8 @@ let eval_binary_op_concrete_compute (binop : E.binop) (v1 : V.typed_value) | Ok sv -> Ok { - V.value = V.Literal (PV.Scalar sv); - ty = T.Literal (Integer sv1.int_ty); + V.value = V.VLiteral (PV.VScalar sv); + ty = T.TLiteral (TInteger sv1.int_ty); }) | E.Shl | E.Shr -> raise Unimplemented | E.Ne | E.Eq -> raise (Failure "Unreachable")) @@ -580,19 +580,19 @@ let eval_binary_op_symbolic (config : C.config) (binop : E.binop) assert (v1.ty = v2.ty); (* Equality/inequality check is primitive only for a subset of types *) assert (ty_is_primitively_copyable v1.ty); - T.Literal Bool) + T.TLiteral TBool) else (* Other operations: input types are integers *) match (v1.V.ty, v2.V.ty) with - | T.Literal (Integer int_ty1), T.Literal (Integer int_ty2) -> ( + | T.TLiteral (TInteger int_ty1), T.TLiteral (TInteger int_ty2) -> ( match binop with | E.Lt | E.Le | E.Ge | E.Gt -> assert (int_ty1 = int_ty2); - T.Literal Bool + T.TLiteral TBool | E.Div | E.Rem | E.Add | E.Sub | E.Mul | E.BitXor | E.BitAnd | E.BitOr -> assert (int_ty1 = int_ty2); - T.Literal (Integer int_ty1) + T.TLiteral (TInteger int_ty1) | E.Shl | E.Shr -> raise Unimplemented | E.Ne | E.Eq -> raise (Failure "Unreachable")) | _ -> raise (Failure "Invalid inputs for binop") @@ -670,7 +670,7 @@ let eval_rvalue_ref (config : C.config) (p : E.place) (bkind : E.borrow_kind) | E.TwoPhaseMut -> T.Mut | _ -> raise (Failure "Unreachable") in - let rv_ty = T.Ref (T.Erased, v.ty, ref_kind) in + let rv_ty = T.Ref (T.RErased, v.ty, ref_kind) in let bc = match bkind with | E.Shared | E.Shallow -> @@ -698,7 +698,7 @@ let eval_rvalue_ref (config : C.config) (p : E.place) (bkind : E.borrow_kind) fun ctx -> (* Compute the rvalue - wrap the value in a mutable borrow with a fresh id *) let bid = C.fresh_borrow_id () in - let rv_ty = T.Ref (T.Erased, v.ty, Mut) in + let rv_ty = T.Ref (T.RErased, v.ty, Mut) in let rv : V.typed_value = { V.value = V.Borrow (V.MutBorrow (bid, v)); ty = rv_ty } in @@ -727,9 +727,9 @@ let eval_rvalue_aggregate (config : C.config) match type_id with | Tuple -> let tys = List.map (fun (v : V.typed_value) -> v.V.ty) values in - let v = V.Adt { variant_id = None; field_values = values } in + let v = V.VAdt { variant_id = None; field_values = values } in let generics = TypesUtils.mk_generic_args [] tys [] [] in - let ty = T.Adt (T.Tuple, generics) in + let ty = T.TAdt (T.Tuple, generics) in let aggregated : V.typed_value = { V.value = v; ty } in (* Call the continuation *) cf aggregated ctx @@ -750,11 +750,11 @@ let eval_rvalue_aggregate (config : C.config) let av : V.adt_value = { V.variant_id = opt_variant_id; V.field_values = values } in - let aty = T.Adt (T.AdtId def_id, generics) in - let aggregated : V.typed_value = { V.value = Adt av; ty = aty } in + let aty = T.TAdt (T.AdtId def_id, generics) in + let aggregated : V.typed_value = { V.value = VAdt av; ty = aty } in (* Call the continuation *) cf aggregated ctx - | Assumed _ -> raise (Failure "Unreachable")) + | TAssumed _ -> raise (Failure "Unreachable")) | E.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); @@ -762,22 +762,20 @@ let eval_rvalue_aggregate (config : C.config) 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.Adt (T.Assumed T.Array, generics) in + let ty = T.TAdt (T.TAssumed T.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_from_ety V.Aggregate ty - in + let saggregated = mk_fresh_symbolic_typed_value V.Aggregate ty in (* Call the continuation *) match cf saggregated ctx with | None -> None | Some e -> (* Introduce the symbolic value in the AST *) let sv = ValuesUtils.value_as_symbolic saggregated.value in - Some (SymbolicAst.IntroSymbolic (ctx, None, sv, Array values, e))) + Some (SymbolicAst.IntroSymbolic (ctx, None, sv, VaArray values, e))) in (* Compose and apply *) comp eval_ops compute cf diff --git a/compiler/InterpreterLoopsCore.ml b/compiler/InterpreterLoopsCore.ml index 6e33c75b9..50bc77674 100644 --- a/compiler/InterpreterLoopsCore.ml +++ b/compiler/InterpreterLoopsCore.ml @@ -343,24 +343,24 @@ let ctx_split_fixed_new (fixed_ids : ids_sets) (ctx : C.eval_ctx) : though) in the target context *) let is_fresh (ee : C.env_elem) : bool = match ee with - | C.Var (VarBinder _, _) | C.Frame -> false - | C.Var (DummyBinder bv, _) -> is_fresh_did bv - | C.Abs abs -> is_fresh_abs_id abs.abs_id + | C.EBinding (BVar _, _) | C.EFrame -> false + | C.EBinding (BDummy bv, _) -> is_fresh_did bv + | C.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.Abs _ -> true | _ -> false in + let is_abs ee = match ee with C.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.Abs abs -> abs | _ -> raise (Failure "Unreachable")) + match ee with C.EAbs abs -> abs | _ -> raise (Failure "Unreachable")) new_absl in let new_dummyl = List.map (fun ee -> match ee with - | C.Var (DummyBinder _, v) -> v + | C.EBinding (BDummy _, v) -> v | _ -> raise (Failure "Unreachable")) new_dummyl in diff --git a/compiler/InterpreterLoopsFixedPoint.ml b/compiler/InterpreterLoopsFixedPoint.ml index 4310f0171..3447131cb 100644 --- a/compiler/InterpreterLoopsFixedPoint.ml +++ b/compiler/InterpreterLoopsFixedPoint.ml @@ -85,7 +85,7 @@ let prepare_ashared_loans (loop_id : V.LoopId.id option) : cm_fun = *) let absl = List.filter_map - (function C.Var _ | C.Frame -> None | C.Abs abs -> Some abs) + (function C.EBinding _ | C.EFrame -> None | C.EAbs abs -> Some abs) ctx.env in let absl_ids, absl_id_maps = compute_absl_ids absl in @@ -109,7 +109,6 @@ let prepare_ashared_loans (loop_id : V.LoopId.id option) : cm_fun = (fun r -> if T.RegionId.Set.mem r rids then nrid else r) (fun x -> x) (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 @@ -163,14 +162,15 @@ let prepare_ashared_loans (loop_id : V.LoopId.id option) : cm_fun = assert (T.RegionId.Set.is_empty abs.ancestors_regions); (* Introduce the new abstraction for the shared values *) - let rty = ety_no_regions_to_rty sv.V.ty in + assert (ty_no_regions sv.V.ty); + let rty = sv.V.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.Ref (T.Var nrid, rty, T.Shared) in + let loan_rty = T.Ref (T.RVar nrid, rty, T.Shared) in let loan_value = V.ALoan (V.ASharedLoan (V.BorrowId.Set.singleton nlid, nsv, child_av)) in @@ -304,7 +304,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.Abs abs) !fresh_absl in + let fresh_absl = List.map (fun abs -> C.EAbs abs) !fresh_absl in let env = List.append fresh_absl env in let ctx = { ctx with env } in @@ -322,7 +322,7 @@ let prepare_ashared_loans (loop_id : V.LoopId.id option) : cm_fun = let sv = V.SymbolicValueId.Map.find sid new_ctx_ids_map.sids_to_values in - SymbolicAst.IntroSymbolic (ctx, None, sv, SingleValue v, e)) + 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) : @@ -865,8 +865,8 @@ let compute_fp_ctx_symbolic_values (ctx : C.eval_ctx) (fp_ctx : C.eval_ctx) : List.filter (fun (ee : C.env_elem) -> match ee with - | C.Var _ | C.Frame -> false - | Abs abs -> V.AbstractionId.Set.mem abs.abs_id old_ids.aids) + | C.EBinding _ | C.EFrame -> false + | EAbs abs -> V.AbstractionId.Set.mem abs.abs_id old_ids.aids) ctx.env in diff --git a/compiler/InterpreterLoopsJoinCtxs.ml b/compiler/InterpreterLoopsJoinCtxs.ml index 6d3ecb184..654ee21b1 100644 --- a/compiler/InterpreterLoopsJoinCtxs.ml +++ b/compiler/InterpreterLoopsJoinCtxs.ml @@ -163,14 +163,14 @@ let collapse_ctx (loop_id : V.LoopId.id) (List.map (fun ee -> match ee with - | C.Abs _ | C.Frame | C.Var (VarBinder _, _) -> [ ee ] - | C.Var (DummyBinder id, v) -> + | C.EAbs _ | C.EFrame | C.EBinding (BVar _, _) -> [ ee ] + | C.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.Abs abs) absl + List.map (fun abs -> C.EAbs abs) absl else [ ee ]) ctx0.env) in @@ -436,14 +436,14 @@ let join_ctxs (loop_id : V.LoopId.id) (fixed_ids : ids_sets) (ctx0 : C.eval_ctx) (* Sanity check: there are no values/abstractions which should be in the prefix *) let check_valid (ee : C.env_elem) : unit = match ee with - | C.Var (C.VarBinder _, _) -> + | C.EBinding (C.BVar _, _) -> (* Variables are necessarily in the prefix *) raise (Failure "Unreachable") - | Var (C.DummyBinder did, _) -> + | EBinding (C.BDummy did, _) -> assert (not (C.DummyVarId.Set.mem did fixed_ids.dids)) - | Abs abs -> + | EAbs abs -> assert (not (V.AbstractionId.Set.mem abs.abs_id fixed_ids.aids)) - | Frame -> + | EFrame -> (* This should have been eliminated *) raise (Failure "Unreachable") in @@ -451,7 +451,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.Abs abs) (List.rev !nabs) in + let absl = List.map (fun abs -> C.EAbs abs) (List.rev !nabs) in List.concat [ env0; env1; absl ] in @@ -466,12 +466,12 @@ let join_ctxs (loop_id : V.LoopId.id) (fixed_ids : ids_sets) (ctx0 : C.eval_ctx) (* Rem.: this function raises exceptions *) let rec join_prefixes (env0 : C.env) (env1 : C.env) : C.env = match (env0, env1) with - | ( (C.Var (C.DummyBinder b0, v0) as var0) :: env0', - (C.Var (C.DummyBinder b1, v1) as var1) :: env1' ) -> + | ( (C.EBinding (C.BDummy b0, v0) as var0) :: env0', + (C.EBinding (C.BDummy b1, v1) as var1) :: env1' ) -> (* Debug *) log#ldebug (lazy - ("join_prefixes: DummyBinders:\n\n- fixed_ids:\n" ^ "\n" + ("join_prefixes: BDummys:\n\n- fixed_ids:\n" ^ "\n" ^ show_ids_sets fixed_ids ^ "\n\n- value0:\n" ^ env_elem_to_string ctx var0 ^ "\n\n- value1:\n" @@ -486,17 +486,17 @@ let join_ctxs (loop_id : V.LoopId.id) (fixed_ids : ids_sets) (ctx0 : C.eval_ctx) assert (b0 = b1); let b = b0 in let v = M.match_typed_values ctx v0 v1 in - let var = C.Var (C.DummyBinder b, v) in + let var = C.EBinding (C.BDummy b, v) in (* Continue *) var :: join_prefixes env0' env1') else (* Not in the prefix anymore *) join_suffixes env0 env1 - | ( (C.Var (C.VarBinder b0, v0) as var0) :: env0', - (C.Var (C.VarBinder b1, v1) as var1) :: env1' ) -> + | ( (C.EBinding (C.BVar b0, v0) as var0) :: env0', + (C.EBinding (C.BVar b1, v1) as var1) :: env1' ) -> (* Debug *) log#ldebug (lazy - ("join_prefixes: VarBinders:\n\n- fixed_ids:\n" ^ "\n" + ("join_prefixes: BVars:\n\n- fixed_ids:\n" ^ "\n" ^ show_ids_sets fixed_ids ^ "\n\n- value0:\n" ^ env_elem_to_string ctx var0 ^ "\n\n- value1:\n" @@ -509,10 +509,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.Var (C.VarBinder b, v) in + let var = C.EBinding (C.BVar b, v) in (* Continue *) var :: join_prefixes env0' env1' - | (C.Abs abs0 as abs) :: env0', C.Abs abs1 :: env1' -> + | (C.EAbs abs0 as abs) :: env0', C.EAbs abs1 :: env1' -> (* Debug *) log#ldebug (lazy @@ -537,7 +537,7 @@ 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.Frame :: env0, C.Frame :: env1 -> (env0, env1) + | C.EFrame :: env0, C.EFrame :: env1 -> (env0, env1) | _ -> raise (Failure "Unreachable") in @@ -546,7 +546,7 @@ let join_ctxs (loop_id : V.LoopId.id) (fixed_ids : ids_sets) (ctx0 : C.eval_ctx) ("- env0:\n" ^ C.show_env env0 ^ "\n\n- env1:\n" ^ C.show_env env1 ^ "\n\n")); - let env = List.rev (C.Frame :: join_prefixes env0 env1) in + let env = List.rev (C.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 *) @@ -560,9 +560,7 @@ let join_ctxs (loop_id : V.LoopId.id) (fixed_ids : ids_sets) (ctx0 : C.eval_ctx) type_vars; const_generic_vars; const_generic_vars_map; - norm_trait_etypes; - norm_trait_rtypes; - norm_trait_stypes; + norm_trait_types; env = _; ended_regions = ended_regions0; } = @@ -578,9 +576,7 @@ let join_ctxs (loop_id : V.LoopId.id) (fixed_ids : ids_sets) (ctx0 : C.eval_ctx) type_vars = _; const_generic_vars = _; const_generic_vars_map = _; - norm_trait_etypes = _; - norm_trait_rtypes = _; - norm_trait_stypes = _; + norm_trait_types = _; env = _; ended_regions = ended_regions1; } = @@ -598,9 +594,7 @@ let join_ctxs (loop_id : V.LoopId.id) (fixed_ids : ids_sets) (ctx0 : C.eval_ctx) type_vars; const_generic_vars; const_generic_vars_map; - norm_trait_etypes; - norm_trait_rtypes; - norm_trait_stypes; + norm_trait_types; env; ended_regions; } @@ -656,7 +650,6 @@ let refresh_abs (old_abs : V.AbstractionId.Set.t) (ctx : C.eval_ctx) : (fun x -> x) (fun x -> x) (fun x -> x) - (fun x -> x) subst ctx.env in { ctx with C.env } diff --git a/compiler/InterpreterLoopsMatchCtxs.ml b/compiler/InterpreterLoopsMatchCtxs.ml index 8cab546e2..9bc25626c 100644 --- a/compiler/InterpreterLoopsMatchCtxs.ml +++ b/compiler/InterpreterLoopsMatchCtxs.ml @@ -144,12 +144,16 @@ let compute_abs_borrows_loans_maps (no_duplicates : bool) borrow_loan_to_abs = !borrow_loan_to_abs; } -(** Match two types during a join. *) -let rec match_types (match_distinct_types : 'r T.ty -> 'r T.ty -> 'r T.ty) - (match_regions : 'r -> 'r -> 'r) (ty0 : 'r T.ty) (ty1 : 'r T.ty) : 'r T.ty = +(** Match two types during a join. + + 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 match_rec = match_types match_distinct_types match_regions in match (ty0, ty1) with - | Adt (id0, generics0), Adt (id1, generics1) -> + | TAdt (id0, generics0), TAdt (id1, generics1) -> assert (id0 = id1); assert (generics0.const_generics = generics1.const_generics); assert (generics0.trait_refs = generics1.trait_refs); @@ -167,12 +171,12 @@ let rec match_types (match_distinct_types : 'r T.ty -> 'r T.ty -> 'r T.ty) (List.combine generics0.types generics1.types) in let generics = { T.regions; types; const_generics; trait_refs } in - Adt (id, generics) + TAdt (id, generics) | TypeVar vid0, TypeVar vid1 -> assert (vid0 = vid1); let vid = vid0 in TypeVar vid - | Literal lty0, Literal lty1 -> + | TLiteral lty0, TLiteral lty1 -> assert (lty0 = lty1); ty0 | Never, Never -> ty0 @@ -190,16 +194,16 @@ module MakeMatcher (M : PrimMatcher) : Matcher = struct 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.Literal lv0, V.Literal lv1 -> + | V.VLiteral lv0, V.VLiteral lv1 -> if lv0 = lv1 then v1 else M.match_distinct_literals ty lv0 lv1 - | V.Adt av0, V.Adt av1 -> + | V.VAdt av0, V.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.Adt { variant_id = av0.variant_id; field_values } + V.VAdt { variant_id = av0.variant_id; field_values } in { V.value; ty = v1.V.ty } else ( @@ -393,7 +397,7 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct let match_distinct_literals (ty : T.ety) (_ : V.literal) (_ : V.literal) : V.typed_value = - mk_fresh_symbolic_typed_value_from_ety V.LoopJoin ty + mk_fresh_symbolic_typed_value_from_no_regions_ty V.LoopJoin ty let match_distinct_adts (ty : T.ety) (adt0 : V.adt_value) (adt1 : V.adt_value) : V.typed_value = @@ -422,7 +426,7 @@ 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_ety V.LoopJoin ty + mk_fresh_symbolic_typed_value_from_no_regions_ty V.LoopJoin ty let match_shared_borrows _ (ty : T.ety) (bid0 : V.borrow_id) (bid1 : V.borrow_id) : V.borrow_id = @@ -439,12 +443,12 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct (* 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_ety V.LoopJoin bv_ty in - - let borrow_ty = - mk_ref_ty (T.Var rid) (ety_no_regions_to_rty bv_ty) kind + let sv = + mk_fresh_symbolic_typed_value_from_no_regions_ty V.LoopJoin bv_ty in + let borrow_ty = mk_ref_ty (T.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 @@ -453,10 +457,7 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct let borrows = [ mk_aborrow bid0; mk_aborrow bid1 ] in let loan = - V.ASharedLoan - ( V.BorrowId.Set.singleton bid2, - sv, - mk_aignored (ety_no_regions_to_rty bv_ty) ) + V.ASharedLoan (V.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 @@ -542,8 +543,9 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct let nbid = C.fresh_borrow_id () in let kind = T.Mut in - let bv_ty = ety_no_regions_to_rty bv.V.ty in - let borrow_ty = mk_ref_ty (T.Var rid) bv_ty kind in + let bv_ty = bv.V.ty in + assert (ty_no_regions bv_ty); + let borrow_ty = mk_ref_ty (T.RVar rid) bv_ty kind in let borrow_av = let ty = borrow_ty in @@ -588,21 +590,22 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct (* 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_ety V.LoopJoin bv_ty in - - let borrow_ty = - mk_ref_ty (T.Var rid) (ety_no_regions_to_rty bv_ty) kind + let sv = + mk_fresh_symbolic_typed_value_from_no_regions_ty V.LoopJoin bv_ty in + let borrow_ty = mk_ref_ty (T.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 = ety_no_regions_to_rty bv.V.ty in + let bv_ty = bv.V.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 } in let borrows = [ mk_aborrow bid0 bv0; mk_aborrow bid1 bv1 ] in - let loan = V.AMutLoan (bid2, mk_aignored (ety_no_regions_to_rty bv_ty)) in + let loan = V.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 @@ -832,17 +835,17 @@ struct let match_distinct_types _ _ = raise (Distinct "match_rtys") in let match_regions r0 r1 = match (r0, r1) with - | T.Static, T.Static -> r1 - | Var rid0, Var rid1 -> + | T.RStatic, T.RStatic -> r1 + | RVar rid0, RVar rid1 -> let rid = match_rid rid0 rid1 in - Var rid + RVar rid | _ -> raise (Distinct "match_rtys") 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_ety V.LoopJoin ty + mk_fresh_symbolic_typed_value_from_no_regions_ty V.LoopJoin ty let match_distinct_adts (_ty : T.ety) (_adt0 : V.adt_value) (_adt1 : V.adt_value) : V.typed_value = @@ -982,7 +985,7 @@ struct (lazy ("MakeCheckEquivMatcher:match_amut_loans:" ^ "\n- id0: " ^ V.BorrowId.to_string id0 ^ "\n- id1: " ^ V.BorrowId.to_string id1 - ^ "\n- ty: " ^ rty_to_string S.ctx ty ^ "\n- av: " + ^ "\n- ty: " ^ PA.ty_to_string S.ctx ty ^ "\n- av: " ^ typed_avalue_to_string S.ctx av)); let id = match_loan_id id0 id1 in @@ -1153,8 +1156,8 @@ let match_ctxs (check_equiv : bool) (fixed_ids : ids_sets) ^ "\n\n")); match (env0, env1) with - | ( C.Var (C.DummyBinder b0, v0) :: env0', - C.Var (C.DummyBinder b1, v1) :: env1' ) -> + | ( C.EBinding (C.BDummy b0, v0) :: env0', + C.EBinding (C.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 ( @@ -1168,14 +1171,14 @@ 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.Var (C.VarBinder b0, v0) :: env0', C.Var (C.VarBinder b1, v1) :: env1' + | C.EBinding (C.BVar b0, v0) :: env0', C.EBinding (C.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.Abs abs0 :: env0', C.Abs abs1 :: env1' -> + | C.EAbs abs0 :: env0', C.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 ( @@ -1211,7 +1214,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.Frame :: env0, C.Frame :: env1 -> (env0, env1) + | C.EFrame :: env0, C.EFrame :: env1 -> (env0, env1) | _ -> raise (Failure "Unreachable") in @@ -1275,7 +1278,7 @@ let match_ctx_with_target (config : C.config) (loop_id : V.LoopId.id) (* Remove the abstractions *) let filter (ee : C.env_elem) : bool = - match ee with Var _ -> true | Abs _ | Frame -> false + match ee with EBinding _ -> true | EAbs _ | EFrame -> false in let filt_src_env = List.filter filter filt_src_env in let filt_tgt_env = List.filter filter filt_tgt_env in @@ -1304,11 +1307,11 @@ let match_ctx_with_target (config : C.config) (loop_id : V.LoopId.id) List.iter (fun (var0, var1) -> match (var0, var1) with - | C.Var (C.DummyBinder b0, v0), C.Var (C.DummyBinder b1, v1) -> + | C.EBinding (C.BDummy b0, v0), C.EBinding (C.BDummy b1, v1) -> assert (b0 = b1); let _ = M.match_typed_values ctx v0 v1 in () - | C.Var (C.VarBinder b0, v0), C.Var (C.VarBinder b1, v1) -> + | C.EBinding (C.BVar b0, v0), C.EBinding (C.BVar b1, v1) -> assert (b0 = b1); let _ = M.match_typed_values ctx v0 v1 in () @@ -1392,7 +1395,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.Abs abs) new_absl } + { src_ctx with C.env = List.map (fun abs -> C.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: " @@ -1585,7 +1588,7 @@ let match_ctx_with_target (config : C.config) (loop_id : V.LoopId.id) end in let new_absl = List.map (visit_src#visit_abs ()) new_absl in - let new_absl = List.map (fun abs -> C.Abs abs) new_absl in + let new_absl = List.map (fun abs -> C.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 diff --git a/compiler/InterpreterPaths.ml b/compiler/InterpreterPaths.ml index 2a277c91d..728e5226e 100644 --- a/compiler/InterpreterPaths.ml +++ b/compiler/InterpreterPaths.ml @@ -97,8 +97,8 @@ let rec access_projection (access : projection_access) (ctx : C.eval_ctx) (* Match on the projection element and the value *) match (pe, v.V.value, v.V.ty) with | ( Field ((ProjAdt (_, _) as proj_kind), field_id), - V.Adt adt, - T.Adt (type_id, _) ) -> ( + V.VAdt adt, + T.TAdt (type_id, _) ) -> ( (* Check consistency *) (match (proj_kind, type_id) with | ProjAdt (def_id, opt_variant_id), T.AdtId def_id' -> @@ -114,11 +114,11 @@ let rec access_projection (access : projection_access) (ctx : C.eval_ctx) let nvalues = T.FieldId.update_nth adt.field_values field_id res.updated in - let nadt = V.Adt { adt with V.field_values = nvalues } in + let nadt = V.VAdt { adt with V.field_values = nvalues } in let updated = { v with value = nadt } in Ok (ctx, { res with updated })) (* Tuples *) - | Field (ProjTuple arity, field_id), V.Adt adt, T.Adt (T.Tuple, _) -> ( + | Field (ProjTuple arity, field_id), V.VAdt adt, T.TAdt (T.Tuple, _) -> ( assert (arity = List.length adt.field_values); let fv = T.FieldId.nth adt.field_values field_id in (* Project *) @@ -129,7 +129,7 @@ let rec access_projection (access : projection_access) (ctx : C.eval_ctx) let nvalues = T.FieldId.update_nth adt.field_values field_id res.updated in - let ntuple = V.Adt { adt with field_values = nvalues } in + let ntuple = V.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 @@ -142,8 +142,8 @@ let rec access_projection (access : projection_access) (ctx : C.eval_ctx) Error (FailSymbolic (1 + List.length p', sp)) (* Box dereferencement *) | ( DerefBox, - Adt { variant_id = None; field_values = [ bv ] }, - T.Adt (T.Assumed T.Box, _) ) -> ( + VAdt { variant_id = None; field_values = [ bv ] }, + T.TAdt (T.TAssumed T.TBox, _) ) -> ( (* We allow moving outside of boxes. In practice, this kind of * manipulations should happen only inside unsafe code, so * it shouldn't happen due to user code, and we leverage it @@ -156,7 +156,7 @@ let rec access_projection (access : projection_access) (ctx : C.eval_ctx) { v with value = - V.Adt { variant_id = None; field_values = [ res.updated ] }; + V.VAdt { variant_id = None; field_values = [ res.updated ] }; } in Ok (ctx, { res with updated = nv })) @@ -248,7 +248,7 @@ let rec access_projection (access : projection_access) (ctx : C.eval_ctx) in Ok (ctx, { res with updated = nv }) else Error (FailSharedLoan bids)) - | (_, (V.Literal _ | V.Adt _ | V.Bottom | V.Borrow _), _) as r -> + | (_, (V.VLiteral _ | V.VAdt _ | V.Bottom | V.Borrow _), _) as r -> let pe, v, ty = r in let pe = "- pe: " ^ E.show_projection_elem pe in let v = "- v:\n" ^ V.show_value v in @@ -357,7 +357,8 @@ let write_place (access : access_kind) (p : E.place) (nv : V.typed_value) let compute_expanded_bottom_adt_value (ctx : C.eval_ctx) (def_id : T.TypeDeclId.id) (opt_variant_id : T.VariantId.id option) - (generics : T.egeneric_args) : V.typed_value = + (generics : T.generic_args) : V.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 @@ -370,17 +371,17 @@ let compute_expanded_bottom_adt_value (ctx : C.eval_ctx) in (* Initialize the expanded value *) let fields = List.map mk_bottom field_types in - let av = V.Adt { variant_id = opt_variant_id; field_values = fields } in - let ty = T.Adt (T.AdtId def_id, generics) in + let av = V.VAdt { variant_id = opt_variant_id; field_values = fields } in + let ty = T.TAdt (T.AdtId def_id, generics) in { V.value = av; V.ty } let compute_expanded_bottom_tuple_value (field_types : T.ety list) : V.typed_value = (* Generate the field values *) let fields = List.map mk_bottom field_types in - let v = V.Adt { variant_id = None; field_values = fields } in + let v = V.VAdt { variant_id = None; field_values = fields } in let generics = TypesUtils.mk_generic_args [] field_types [] [] in - let ty = T.Adt (T.Tuple, generics) in + let ty = T.TAdt (T.Tuple, generics) in { V.value = v; V.ty } (** Auxiliary helper to expand {!V.Bottom} values. @@ -432,12 +433,12 @@ let expand_bottom_value_from_projection (access : access_kind) (p : E.place) match (pe, ty) with (* "Regular" ADTs *) | ( Field (ProjAdt (def_id, opt_variant_id), _), - T.Adt (T.AdtId def_id', generics) ) -> + T.TAdt (T.AdtId 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.Adt + T.TAdt ( T.Tuple, { T.regions = []; types; const_generics = []; trait_refs = [] } ) ) -> diff --git a/compiler/InterpreterPaths.mli b/compiler/InterpreterPaths.mli index 0ff8063f6..a493ad69b 100644 --- a/compiler/InterpreterPaths.mli +++ b/compiler/InterpreterPaths.mli @@ -55,12 +55,15 @@ val write_place : *) val compute_expanded_bottom_tuple_value : T.ety list -> V.typed_value -(** Compute an expanded ADT ⊥ 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.egeneric_args -> + T.generic_args -> V.typed_value (** Drop (end) outer loans at a given place, which should be seen as an l-value diff --git a/compiler/InterpreterProjectors.ml b/compiler/InterpreterProjectors.ml index 9e0c2b75c..70a77be50 100644 --- a/compiler/InterpreterProjectors.ml +++ b/compiler/InterpreterProjectors.ml @@ -12,20 +12,21 @@ open InterpreterBorrowsCore (** The local logger *) let log = L.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 = - (* Sanity check - TODO: move this elsewhere (here we perform the check at every + (* 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 - assert (ety = v.V.ty); + assert (ty_is_rty ty && ety = v.V.ty); (* Project - if there are no regions from the abstraction in the type, return [_] *) if not (ty_has_regions_in_set regions ty) then [] else match (v.V.value, ty) with - | V.Literal _, T.Literal _ -> [] - | V.Adt adt, T.Adt (id, generics) -> + | V.VLiteral _, T.TLiteral _ -> [] + | V.VAdt adt, T.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 @@ -97,14 +98,14 @@ let rec apply_proj_borrows (check_symbolic_no_ended : bool) (ctx : C.eval_ctx) (* Sanity check - TODO: move this elsewhere (here we perform the check at every * recursive call which is a bit overkill...) *) let ety = Substitute.erase_regions ty in - assert (ety = v.V.ty); + assert (ty_is_rty ty && ety = v.V.ty); (* Project - if there are no regions from the abstraction in the type, return [_] *) if not (ty_has_regions_in_set regions ty) then { V.value = V.AIgnored; ty } else let value : V.avalue = match (v.V.value, ty) with - | V.Literal _, T.Literal _ -> V.AIgnored - | V.Adt adt, T.Adt (id, generics) -> + | V.VLiteral _, T.TLiteral _ -> V.AIgnored + | V.VAdt adt, T.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 @@ -208,10 +209,10 @@ 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: " ^ rty_to_string ctx ty1 - ^ "\n- rset1: " + ("projections_intersect:" ^ "\n- ty1: " + ^ PA.ty_to_string ctx ty1 ^ "\n- rset1: " ^ T.RegionId.Set.to_string None rset1 - ^ "\n- ty2: " ^ rty_to_string ctx ty2 ^ "\n- rset2: " + ^ "\n- ty2: " ^ PA.ty_to_string ctx ty2 ^ "\n- rset2: " ^ T.RegionId.Set.to_string None rset2 ^ "\n")); assert (not (projections_intersect ty1 rset1 ty2 rset2))); @@ -221,7 +222,7 @@ let rec apply_proj_borrows (check_symbolic_no_ended : bool) (ctx : C.eval_ctx) (lazy ("apply_proj_borrows: unexpected inputs:\n- input value: " ^ typed_value_to_string ctx v - ^ "\n- proj rty: " ^ rty_to_string ctx ty)); + ^ "\n- proj rty: " ^ PA.ty_to_string ctx ty)); raise (Failure "Unreachable") in { V.value; V.ty } @@ -231,12 +232,12 @@ let symbolic_expansion_non_borrow_to_value (sv : V.symbolic_value) let ty = Subst.erase_regions sv.V.sv_ty in let value = match see with - | SeLiteral cv -> V.Literal cv + | SeLiteral cv -> V.VLiteral cv | SeAdt (variant_id, field_values) -> let field_values = List.map mk_typed_value_from_symbolic_value field_values in - V.Adt { V.variant_id; V.field_values } + V.VAdt { V.variant_id; V.field_values } | SeMutRef (_, _) | SeSharedRef (_, _) -> raise (Failure "Unexpected symbolic reference expansion") in @@ -265,10 +266,10 @@ let apply_proj_loans_on_symbolic_expansion (regions : T.RegionId.Set.t) * contain regions which we will project *) assert (ty_has_regions_in_set regions original_sv_ty); (* Match *) - let (value, ty) : V.avalue * T.rty = + let (value, ty) : V.avalue * T.ty = match (see, original_sv_ty) with - | SeLiteral _, T.Literal _ -> (V.AIgnored, original_sv_ty) - | SeAdt (variant_id, field_values), T.Adt (_id, _generics) -> + | SeLiteral _, T.TLiteral _ -> (V.AIgnored, original_sv_ty) + | SeAdt (variant_id, field_values), T.TAdt (_id, _generics) -> (* Project over the field values *) let field_values = List.map @@ -493,9 +494,11 @@ let prepare_reborrows (config : C.config) (allow_reborrows : bool) : 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 = + assert (ty_is_rty ty); let check_symbolic_no_ended = true in let allow_reborrows = true in (* Prepare the reborrows *) diff --git a/compiler/InterpreterProjectors.mli b/compiler/InterpreterProjectors.mli index bcc3dee29..7cee9ee74 100644 --- a/compiler/InterpreterProjectors.mli +++ b/compiler/InterpreterProjectors.mli @@ -16,7 +16,7 @@ open InterpreterBorrowsCore [regions] [ancestor_regions] [see] - [original_sv_ty] + [original_sv_ty]: shouldn't have erased regions *) val apply_proj_loans_on_symbolic_expansion : T.RegionId.Set.t -> @@ -121,8 +121,8 @@ val apply_proj_borrows : - [regions]: the regions to project - [ancestors_regions] - [v]: the value on which to apply the projection - - [ty]: the type (with regions) to use for the projection - + - [ty]: the type (with regions) to use for the projection (shouldn't have + erased regions) *) val apply_proj_borrows_on_input_value : C.config -> diff --git a/compiler/InterpreterStatements.ml b/compiler/InterpreterStatements.ml index e0c4703b0..cdcea2ccc 100644 --- a/compiler/InterpreterStatements.ml +++ b/compiler/InterpreterStatements.ml @@ -149,7 +149,7 @@ let eval_assertion_concrete (config : C.config) (assertion : A.assertion) : let eval_assert cf (v : V.typed_value) : m_fun = fun ctx -> match v.value with - | Literal (Bool b) -> + | VLiteral (VBool b) -> (* Branch *) if b = assertion.expected then cf Unit ctx else cf Panic ctx | _ -> @@ -172,26 +172,26 @@ let eval_assertion (config : C.config) (assertion : A.assertion) : st_cm_fun = (* Evaluate the assertion *) let eval_assert cf (v : V.typed_value) : m_fun = fun ctx -> - assert (v.ty = T.Literal PV.Bool); + assert (v.ty = T.TLiteral PV.TBool); (* We make a choice here: we could completely decouple the concrete and * symbolic executions here but choose not to. In the case where we * know the concrete value of the boolean we test, we use this value * even if we are in symbolic mode. Note that this case should be * extremely rare... *) match v.value with - | Literal (Bool _) -> + | VLiteral (VBool _) -> (* Delegate to the concrete evaluation function *) eval_assertion_concrete config assertion cf ctx | Symbolic sv -> assert (config.mode = C.SymbolicMode); - assert (sv.V.sv_ty = T.Literal PV.Bool); + assert (sv.V.sv_ty = T.TLiteral PV.TBool); (* We continue the execution as if the test had succeeded, and thus * perform the symbolic expansion: sv ~~> true. * We will of course synthesize an assertion in the generated code * (see below). *) let ctx = apply_symbolic_expansion_non_borrow config sv - (V.SeLiteral (PV.Bool true)) ctx + (V.SeLiteral (PV.VBool true)) ctx in (* Continue *) let expr = cf Unit ctx in @@ -232,7 +232,7 @@ let set_discriminant (config : C.config) (p : E.place) let update_value cf (v : V.typed_value) : m_fun = fun ctx -> match (v.V.ty, v.V.value) with - | T.Adt ((T.AdtId _ as type_id), generics), V.Adt av -> ( + | T.TAdt ((T.AdtId _ as type_id), generics), V.VAdt av -> ( (* There are two situations: - either the discriminant is already the proper one (in which case we don't do anything) @@ -254,7 +254,7 @@ let set_discriminant (config : C.config) (p : E.place) | _ -> raise (Failure "Unreachable") in assign_to_place config bottom_v p (cf Unit) ctx) - | T.Adt ((T.AdtId _ as type_id), generics), V.Bottom -> + | T.TAdt ((T.AdtId _ as type_id), generics), V.Bottom -> let bottom_v = match type_id with | T.AdtId def_id -> @@ -273,8 +273,8 @@ let set_discriminant (config : C.config) (p : E.place) * setting a discriminant should only be used to initialize a value, * or reset an already initialized value, really. *) raise (Failure "Unexpected value") - | _, (V.Adt _ | V.Bottom) -> raise (Failure "Inconsistent state") - | _, (V.Literal _ | V.Borrow _ | V.Loan _) -> + | _, (V.VAdt _ | V.Bottom) -> raise (Failure "Inconsistent state") + | _, (V.VLiteral _ | V.Borrow _ | V.Loan _) -> raise (Failure "Unexpected value") in (* Compose and apply *) @@ -282,7 +282,7 @@ let set_discriminant (config : C.config) (p : E.place) (** Push a frame delimiter in the context's environment *) let ctx_push_frame (ctx : C.eval_ctx) : C.eval_ctx = - { ctx with env = Frame :: ctx.env } + { ctx with env = EFrame :: ctx.env } (** Push a frame delimiter in the context's environment *) let push_frame : cm_fun = fun cf ctx -> cf (ctx_push_frame ctx) @@ -291,7 +291,7 @@ let push_frame : cm_fun = fun cf ctx -> cf (ctx_push_frame ctx) instantiation of an assumed function. *) let get_assumed_function_return_type (ctx : C.eval_ctx) (fid : A.assumed_fun_id) - (generics : T.egeneric_args) : T.ety = + (generics : T.generic_args) : T.ety = assert (generics.trait_refs = []); (* [Box::free] has a special treatment *) match fid with @@ -305,17 +305,16 @@ 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.erased_region T.trait_instance_id = - T.UnknownTrait __FUNCTION__ - in + let tr_self : T.trait_instance_id = T.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_esubst_from_generics sg.generics generics tr_self + Subst.make_subst_from_generics sg.generics generics tr_self in let ty = Subst.erase_regions_substitute_types ty_subst cg_subst tr_subst tr_self sg.output in - Assoc.ctx_normalize_ety ctx ty + Assoc.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 = @@ -337,12 +336,12 @@ let pop_frame (config : C.config) (pop_return_value : bool) let rec list_locals env = match env with | [] -> raise (Failure "Inconsistent environment") - | C.Abs _ :: env -> list_locals env - | C.Var (DummyBinder _, _) :: env -> list_locals env - | C.Var (VarBinder var, _) :: env -> + | C.EAbs _ :: env -> list_locals env + | C.EBinding (BDummy _, _) :: env -> list_locals env + | C.EBinding (BVar var, _) :: env -> let locals = list_locals env in if var.index <> ret_vid then var.index :: locals else locals - | C.Frame :: _ -> [] + | C.EFrame :: _ -> [] in let locals : E.VarId.id list = list_locals ctx.env in (* Debug *) @@ -392,11 +391,11 @@ let pop_frame (config : C.config) (pop_return_value : bool) let rec pop env = match env with | [] -> raise (Failure "Inconsistent environment") - | C.Abs abs :: env -> C.Abs abs :: pop env - | C.Var (_, v) :: env -> + | C.EAbs abs :: env -> C.EAbs abs :: pop env + | C.EBinding (_, v) :: env -> let vid = C.fresh_dummy_var_id () in - C.Var (C.DummyBinder vid, v) :: pop env - | C.Frame :: env -> (* Stop here *) env + C.EBinding (C.BDummy vid, v) :: pop env + | C.EFrame :: env -> (* Stop here *) env in let cf_pop cf (ret_value : V.typed_value option) : m_fun = fun ctx -> @@ -416,7 +415,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.egeneric_args) : +let eval_box_new_concrete (config : C.config) (generics : T.generic_args) : cm_fun = fun cf ctx -> (* Check and retrieve the arguments *) @@ -426,9 +425,9 @@ let eval_box_new_concrete (config : C.config) (generics : T.egeneric_args) : | ( [], [ boxed_ty ], [], - Var (VarBinder input_var, input_value) - :: Var (_ret_var, _) - :: C.Frame :: _ ) -> + EBinding (BVar input_var, input_value) + :: EBinding (_ret_var, _) + :: C.EFrame :: _ ) -> (* Required type checking *) assert (input_value.V.ty = boxed_ty); @@ -441,9 +440,9 @@ let eval_box_new_concrete (config : C.config) (generics : T.egeneric_args) : let cf_create cf (moved_input_value : V.typed_value) : m_fun = (* Create the box value *) let generics = TypesUtils.mk_generic_args_from_types [ boxed_ty ] in - let box_ty = T.Adt (T.Assumed T.Box, generics) in + let box_ty = T.TAdt (T.TAssumed T.TBox, generics) in let box_v = - V.Adt { variant_id = None; field_values = [ moved_input_value ] } + V.VAdt { variant_id = None; field_values = [ moved_input_value ] } in let box_v = mk_typed_value box_ty box_v in @@ -478,7 +477,7 @@ let eval_box_new_concrete (config : C.config) (generics : T.egeneric_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.egeneric_args) +let eval_box_free (config : C.config) (generics : T.generic_args) (args : E.operand list) (dest : E.place) : cm_fun = fun cf ctx -> match (generics.regions, generics.types, generics.const_generics, args) with @@ -657,7 +656,7 @@ let create_push_abstractions_from_abs_region_groups (* Add the avalues to the abstraction *) let abs = { abs with avalues } in (* Insert the abstraction in the context *) - let ctx = { ctx with env = Abs abs :: ctx.env } in + let ctx = { ctx with env = EAbs abs :: ctx.env } in (* Return *) ctx in @@ -768,7 +767,7 @@ and eval_global (config : C.config) (dest : E.place) (gid : LA.GlobalDeclId.id) (* Treat the evaluation of the global as a call to the global body (without arguments) *) let func = { - E.func = FunId (Regular global.body_id); + E.func = FunId (FRegular global.body_id); generics = TypesUtils.mk_empty_generic_args; trait_and_method_generic_args = None; } @@ -779,9 +778,8 @@ and eval_global (config : C.config) (dest : E.place) (gid : LA.GlobalDeclId.id) | SymbolicMode -> (* Generate a fresh symbolic value. In the translation, this fresh symbolic value will be * defined as equal to the value of the global (see {!S.synthesize_global_eval}). *) - let sval = - mk_fresh_symbolic_value V.Global (ety_no_regions_to_rty global.ty) - in + assert (ty_no_regions global.ty); + let sval = mk_fresh_symbolic_value V.Global global.ty in let cc = assign_to_place config (mk_typed_value_from_symbolic_value sval) dest in @@ -810,7 +808,7 @@ and eval_switch (config : C.config) (switch : A.switch) : st_cm_fun = let cf_if (cf : st_m_fun) (op_v : V.typed_value) : m_fun = fun ctx -> match op_v.value with - | V.Literal (PV.Bool b) -> + | V.VLiteral (PV.VBool b) -> (* Evaluate the if and the branch body *) let cf_branch cf : m_fun = (* Branch *) @@ -838,7 +836,7 @@ and eval_switch (config : C.config) (switch : A.switch) : st_cm_fun = let cf_switch (cf : st_m_fun) (op_v : V.typed_value) : m_fun = fun ctx -> match op_v.value with - | V.Literal (PV.Scalar sv) -> + | V.VLiteral (PV.VScalar sv) -> (* Evaluate the branch *) let cf_eval_branch cf = (* Sanity check *) @@ -893,7 +891,7 @@ and eval_switch (config : C.config) (switch : A.switch) : st_cm_fun = let p_v = value_strip_shared_loans p_v in (* Match *) match p_v.value with - | V.Adt adt -> ( + | V.VAdt adt -> ( (* Evaluate the discriminant *) let dv = Option.get adt.variant_id in (* Find the branch, evaluate and continue *) @@ -931,9 +929,9 @@ and eval_function_call_concrete (config : C.config) (call : A.call) : st_cm_fun = fun cf ctx -> match call.func.func with - | FunId (Regular fid) -> + | FunId (FRegular fid) -> eval_transparent_function_call_concrete config fid call cf ctx - | FunId (Assumed fid) -> + | FunId (FAssumed fid) -> (* Continue - note that we do as if the function call has been successful, * by giving {!Unit} to the continuation, because we place us in the case * where we haven't panicked. Of course, the translation needs to take the @@ -944,9 +942,9 @@ and eval_function_call_concrete (config : C.config) (call : A.call) : st_cm_fun and eval_function_call_symbolic (config : C.config) (call : A.call) : st_cm_fun = match call.func.func with - | FunId (Regular _) | TraitMethod _ -> + | FunId (FRegular _) | TraitMethod _ -> eval_transparent_function_call_symbolic config call - | FunId (Assumed fid) -> eval_assumed_function_call_symbolic config fid 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) @@ -975,7 +973,7 @@ and eval_transparent_function_call_concrete (config : C.config) (* There shouldn't be any reference to Self *) let tr_self = T.UnknownTrait __FUNCTION__ in let subst = - Subst.make_esubst_from_generics def.A.signature.generics generics tr_self + Subst.make_subst_from_generics def.A.signature.generics generics tr_self in let locals, body_st = Subst.fun_body_substitute_in_body subst body in @@ -1106,13 +1104,13 @@ and eval_transparent_function_call_symbolic (config : C.config) (call : A.call) *) let func, generics, def, inst_sg = match call.func.func with - | FunId (Regular fid) -> + | FunId (FRegular fid) -> let def = C.ctx_lookup_fun_decl ctx fid in log#ldebug (lazy ("fun call:\n- call: " ^ call_to_string ctx call ^ "\n- call.generics:\n" - ^ egeneric_args_to_string ctx call.func.generics + ^ PA.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 @@ -1120,7 +1118,7 @@ and eval_transparent_function_call_symbolic (config : C.config) (call : A.call) instantiate_fun_sig ctx call.func.generics tr_self def.A.signature in (call.func.func, call.func.generics, def, inst_sg) - | FunId (Assumed _) -> + | FunId (FAssumed _) -> (* Unreachable: must be a transparent function *) raise (Failure "Unreachable") | TraitMethod (trait_ref, method_name, _) -> ( @@ -1128,9 +1126,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" - ^ egeneric_args_to_string ctx call.func.generics + ^ PA.generic_args_to_string ctx call.func.generics ^ "\n- trait and method generics:\n" - ^ egeneric_args_to_string ctx + ^ PA.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 *) @@ -1155,9 +1153,7 @@ and eval_transparent_function_call_symbolic (config : C.config) (call : A.call) (* This is a required method *) let method_def = C.ctx_lookup_fun_decl ctx id in (* Instantiate *) - let tr_self = - T.TraitRef (etrait_ref_no_regions_to_gr_trait_ref trait_ref) - in + let tr_self = T.TraitRef trait_ref in let inst_sg = instantiate_fun_sig ctx generics tr_self method_def.A.signature @@ -1168,7 +1164,7 @@ 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 (Regular id) in + let func = E.FunId (FRegular id) in (func, generics, method_def, inst_sg) | None -> (* If not found, lookup the methods provided by the trait *declaration* @@ -1210,13 +1206,11 @@ 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" - ^ egeneric_args_to_string ctx all_generics + ^ PA.generic_args_to_string ctx all_generics ^ "\n- parent params info: " ^ Print.option_to_string A.show_params_info method_def.signature.parent_params_info)); - let tr_self = - T.TraitRef (etrait_ref_no_regions_to_gr_trait_ref trait_ref) - in + let tr_self = T.TraitRef trait_ref in let inst_sg = instantiate_fun_sig ctx all_generics tr_self method_def.A.signature @@ -1243,10 +1237,6 @@ and eval_transparent_function_call_symbolic (config : C.config) (call : A.call) log#ldebug (lazy ("method:\n" ^ fun_decl_to_string ctx method_def)); (* Instantiate *) let tr_self = T.TraitRef trait_ref in - let tr_self = - TypesUtils.etrait_instance_id_no_regions_to_gr_trait_instance_id - tr_self - in let inst_sg = instantiate_fun_sig ctx generics tr_self method_def.A.signature in @@ -1271,7 +1261,7 @@ and eval_transparent_function_call_symbolic (config : C.config) (call : A.call) *) 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.egeneric_args) (args : E.operand list) (dest : E.place) : + (generics : T.generic_args) (args : E.operand list) (dest : E.place) : st_cm_fun = fun cf ctx -> log#ldebug @@ -1281,7 +1271,7 @@ 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" - ^ egeneric_args_to_string ctx generics + ^ PA.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)); @@ -1454,7 +1444,7 @@ and eval_assumed_function_call_symbolic (config : C.config) in (* Evaluate the function call *) - eval_function_call_symbolic_from_inst_sig config (FunId (Assumed fid)) + eval_function_call_symbolic_from_inst_sig config (FunId (FAssumed fid)) inst_sig generics args dest cf ctx (** Evaluate a statement seen as a function body *) diff --git a/compiler/InterpreterUtils.ml b/compiler/InterpreterUtils.ml index 6e08e553c..6f62b577c 100644 --- a/compiler/InterpreterUtils.ml +++ b/compiler/InterpreterUtils.ml @@ -31,8 +31,6 @@ 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 ety_to_string = PA.ety_to_string -let rty_to_string = PA.rty_to_string let symbolic_value_to_string = PA.symbolic_value_to_string let borrow_content_to_string = PA.borrow_content_to_string let loan_content_to_string = PA.loan_content_to_string @@ -43,8 +41,6 @@ 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 egeneric_args_to_string = PA.egeneric_args_to_string -let rtrait_instance_id_to_string = PA.rtrait_instance_id_to_string let fun_sig_to_string = PA.fun_sig_to_string let inst_fun_sig_to_string = PA.inst_fun_sig_to_string @@ -66,8 +62,7 @@ let abs_to_string ctx = PA.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 mk_var (index : E.VarId.id) (name : string option) (var_ty : T.ety) : A.var - = +let mk_var (index : E.VarId.id) (name : string option) (var_ty : T.ty) : A.var = { A.index; name; var_ty } (** Small helper - TODO: move *) @@ -75,25 +70,32 @@ let mk_place_from_var_id (var_id : E.VarId.id) : E.place = { var_id; projection = [] } (** Create a fresh symbolic value *) -let mk_fresh_symbolic_value (sv_kind : V.sv_kind) (ty : T.rty) : - V.symbolic_value = +let mk_fresh_symbolic_value (sv_kind : V.sv_kind) (ty : T.ty) : V.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 svalue +let mk_fresh_symbolic_value_from_no_regions_ty (sv_kind : V.sv_kind) (ty : T.ty) + : V.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.rty) : +let mk_fresh_symbolic_typed_value (sv_kind : V.sv_kind) (rty : T.ty) : V.typed_value = + assert (ty_is_rty rty); let ty = Subst.erase_regions rty in (* Generate the fresh a symbolic value *) let value = mk_fresh_symbolic_value sv_kind rty in let value = V.Symbolic value in { V.value; V.ty } -(** Create a fresh symbolic value *) -let mk_fresh_symbolic_typed_value_from_ety (sv_kind : V.sv_kind) (ety : T.ety) : - V.typed_value = - let ty = TypesUtils.ety_no_regions_to_rty ety in +let mk_fresh_symbolic_typed_value_from_no_regions_ty (sv_kind : V.sv_kind) + (ty : T.ty) : V.typed_value = + assert (ty_no_regions ty); mk_fresh_symbolic_typed_value sv_kind ty (** Create a typed value from a symbolic value. *) @@ -122,7 +124,8 @@ let mk_aproj_loans_value_from_symbolic_value (regions : T.RegionId.Set.t) (** Create a borrows projector from a symbolic value *) let mk_aproj_borrows_from_symbolic_value (proj_regions : T.RegionId.Set.t) - (svalue : V.symbolic_value) (proj_ty : T.rty) : V.aproj = + (svalue : V.symbolic_value) (proj_ty : T.ty) : V.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 @@ -193,7 +196,7 @@ exception FoundGBorrowContent of g_borrow_content exception FoundGLoanContent of g_loan_content (** Utility exception *) -exception FoundAProjBorrows of V.symbolic_value * T.rty +exception FoundAProjBorrows of V.symbolic_value * T.ty let symbolic_value_id_in_ctx (sv_id : V.SymbolicValueId.id) (ctx : C.eval_ctx) : bool = @@ -235,7 +238,7 @@ let symbolic_value_id_in_ctx (sv_id : V.SymbolicValueId.id) (ctx : C.eval_ctx) : *) let symbolic_value_has_ended_regions (ended_regions : T.RegionId.Set.t) (s : V.symbolic_value) : bool = - let regions = rty_regions s.V.sv_ty in + let regions = ty_regions s.V.sv_ty in not (T.RegionId.Set.disjoint regions ended_regions) (** Check if a {!type:V.value} contains [⊥]. @@ -435,7 +438,7 @@ let initialize_eval_context (ctx : C.decls_ctx) T.ConstGenericVarId.Map.of_list (List.map (fun (cg : T.const_generic_var) -> - let ty = TypesUtils.ety_no_regions_to_rty (T.Literal cg.ty) in + let ty = T.TLiteral cg.ty in let cv = mk_fresh_symbolic_typed_value V.ConstGeneric ty in (cg.index, cv)) const_generic_vars) @@ -450,28 +453,27 @@ let initialize_eval_context (ctx : C.decls_ctx) C.type_vars; C.const_generic_vars; C.const_generic_vars_map; - C.norm_trait_etypes = C.ETraitTypeRefMap.empty (* Empty for now *); - C.norm_trait_rtypes = C.RTraitTypeRefMap.empty (* Empty for now *); - C.norm_trait_stypes = C.STraitTypeRefMap.empty (* Empty for now *); - C.env = [ C.Frame ]; + C.norm_trait_types = C.TraitTypeRefMap.empty (* Empty for now *); + C.env = [ C.EFrame ]; C.ended_regions = T.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). - - Note: there are no region parameters, because they should be erased. *) -let instantiate_fun_sig (ctx : C.eval_ctx) (generics : T.egeneric_args) - (tr_self : T.rtrait_instance_id) (sg : A.fun_sig) : A.inst_fun_sig = +let instantiate_fun_sig (ctx : C.eval_ctx) (generics : T.generic_args) + (tr_self : T.trait_instance_id) (sg : A.fun_sig) : A.inst_fun_sig = log#ldebug (lazy ("instantiate_fun_sig:" ^ "\n- generics: " - ^ egeneric_args_to_string ctx generics + ^ PA.generic_args_to_string ctx generics ^ "\n- tr_self: " - ^ rtrait_instance_id_to_string ctx tr_self + ^ PA.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 (* Generate fresh abstraction ids and create a substitution from region * group ids to abstraction ids *) let rg_abs_ids_bindings = @@ -492,29 +494,20 @@ let instantiate_fun_sig (ctx : C.eval_ctx) (generics : T.egeneric_args) (* Generate fresh regions and their substitutions *) let _, rsubst, _ = Subst.fresh_regions_with_substs sg.generics.regions in (* Generate the type substitution - * Note that we need the substitution to map the type variables to - * {!rty} types (not {!ety}). In order to do that, we convert the - * type parameters to types with regions. This is possible only - * if those types don't contain any regions. - * This is a current limitation of the analysis: there is still some - * work to do to properly handle full type parametrization. - * *) - let rtype_params = List.map ety_no_regions_to_rty generics.types in - let tsubst = Subst.make_type_subst_from_vars sg.generics.types rtype_params in + 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 + in let cgsubst = Subst.make_const_generic_subst_from_vars sg.generics.const_generics generics.const_generics in - (* TODO: something annoying with the trait ref subst: we need to use region - types, but the arguments use erased regions. For now we use the fact - that no regions should appear inside. In the future: we should merge - ety and rty. *) - let trait_refs = - List.map TypesUtils.etrait_ref_no_regions_to_gr_trait_ref - generics.trait_refs - in let tr_subst = - Subst.make_trait_subst_from_clauses sg.generics.trait_clauses trait_refs + Subst.make_trait_subst_from_clauses sg.generics.trait_clauses + generics.trait_refs in (* Substitute the signature *) let inst_sig = diff --git a/compiler/Invariants.ml b/compiler/Invariants.ml index 5c8ec7aff..01de6fd04 100644 --- a/compiler/Invariants.ml +++ b/compiler/Invariants.ml @@ -138,13 +138,13 @@ let check_loans_borrows_relation_invariant (ctx : C.eval_ctx) : unit = object inherit [_] C.iter_eval_ctx as super - method! visit_Var _ binder v = + method! visit_EBinding _ binder v = let inside_abs = false in - super#visit_Var inside_abs binder v + super#visit_EBinding inside_abs binder v - method! visit_Abs _ abs = + method! visit_EAbs _ abs = let inside_abs = true in - super#visit_Abs inside_abs abs + super#visit_EAbs inside_abs abs method! visit_loan_content inside_abs lc = (* Register the loan *) @@ -380,8 +380,8 @@ let check_borrowed_values_invariant (ctx : C.eval_ctx) : unit = let check_literal_type (cv : V.literal) (ty : PV.literal_type) : unit = match (cv, ty) with - | PV.Scalar sv, PV.Integer int_ty -> assert (sv.int_ty = int_ty) - | PV.Bool _, PV.Bool | PV.Char _, PV.Char -> () + | PV.VScalar sv, PV.TInteger int_ty -> assert (sv.int_ty = int_ty) + | PV.VBool _, PV.TBool | PV.VChar _, PV.TChar -> () | _ -> raise (Failure "Erroneous typing") let check_typing_invariant (ctx : C.eval_ctx) : unit = @@ -389,10 +389,10 @@ let check_typing_invariant (ctx : C.eval_ctx) : unit = * of the shape [& (mut) T] where they should have type [T]... * This messes a bit the type invariant checks when checking the * children. In order to isolate the problem (for future modifications) - * we introduce function, so that we can easily spot all the involved + * we introduce this function, so that we can easily spot all the involved * places. * *) - let aloan_get_expected_child_type (ty : 'r T.ty) : 'r T.ty = + let aloan_get_expected_child_type (ty : T.ty) : T.ty = let _, ty, _ = ty_get_ref ty in ty in @@ -402,12 +402,24 @@ let check_typing_invariant (ctx : C.eval_ctx) : unit = inherit [_] C.iter_eval_ctx as super method! visit_abs _ abs = super#visit_abs (Some abs) abs + method! visit_EBinding info binder v = + (* We also check that the regions are erased *) + assert (ty_is_ety v.ty); + super#visit_EBinding info binder v + + method! visit_symbolic_value inside_abs v = + (* Check that the types have regions *) + assert (ty_is_rty v.sv_ty); + super#visit_symbolic_value inside_abs v + method! visit_typed_value info tv = + (* Check that the types have erased regions *) + assert (ty_is_ety tv.ty); (* Check the current pair (value, type) *) (match (tv.V.value, tv.V.ty) with - | V.Literal cv, T.Literal ty -> check_literal_type cv ty + | V.VLiteral cv, T.TLiteral ty -> check_literal_type cv ty (* ADT case *) - | V.Adt av, T.Adt (T.AdtId def_id, generics) -> + | V.VAdt av, T.TAdt (T.AdtId 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 @@ -430,10 +442,10 @@ let check_typing_invariant (ctx : C.eval_ctx) : unit = List.combine av.V.field_values field_types in List.iter - (fun ((v, ty) : V.typed_value * T.ety) -> assert (v.V.ty = ty)) + (fun ((v, ty) : V.typed_value * T.ty) -> assert (v.V.ty = ty)) fields_with_types (* Tuple case *) - | V.Adt av, T.Adt (T.Tuple, generics) -> + | V.VAdt av, T.TAdt (T.Tuple, generics) -> assert (generics.regions = []); assert (generics.const_generics = []); assert (av.V.variant_id = None); @@ -443,10 +455,10 @@ let check_typing_invariant (ctx : C.eval_ctx) : unit = List.combine av.V.field_values generics.types in List.iter - (fun ((v, ty) : V.typed_value * T.ety) -> assert (v.V.ty = ty)) + (fun ((v, ty) : V.typed_value * T.ty) -> assert (v.V.ty = ty)) fields_with_types (* Assumed type case *) - | V.Adt av, T.Adt (T.Assumed aty_id, generics) -> ( + | V.VAdt av, T.TAdt (T.TAssumed aty_id, generics) -> ( assert (av.V.variant_id = None); match ( aty_id, @@ -456,9 +468,9 @@ let check_typing_invariant (ctx : C.eval_ctx) : unit = generics.const_generics ) with (* Box *) - | T.Box, [ inner_value ], [], [ inner_ty ], [] -> + | T.TBox, [ inner_value ], [], [ inner_ty ], [] -> assert (inner_value.V.ty = inner_ty) - | T.Array, inner_values, _, [ inner_ty ], [ cg ] -> + | T.TArray, inner_values, _, [ inner_ty ], [ cg ] -> (* *) assert ( List.for_all @@ -471,7 +483,7 @@ let check_typing_invariant (ctx : C.eval_ctx) : unit = .value in assert (Z.of_int (List.length inner_values) = len) - | (T.Slice | T.Str), _, _, _, _ -> raise (Failure "Unexpected") + | (T.TSlice | T.TStr), _, _, _, _ -> raise (Failure "Unexpected") | _ -> raise (Failure "Erroneous type")) | V.Bottom, _ -> (* Nothing to check *) () | V.Borrow bc, T.Ref (_, ref_ty, rkind) -> ( @@ -516,10 +528,12 @@ let check_typing_invariant (ctx : C.eval_ctx) : unit = * so the cost of maintenance should be pretty low. * *) method! visit_typed_avalue info atv = + (* Check that the types have regions *) + assert (ty_is_rty atv.ty); (* Check the current pair (value, type) *) (match (atv.V.value, atv.V.ty) with (* ADT case *) - | V.AAdt av, T.Adt (T.AdtId def_id, generics) -> + | V.AAdt av, T.TAdt (T.AdtId 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 @@ -545,10 +559,10 @@ let check_typing_invariant (ctx : C.eval_ctx) : unit = List.combine av.V.field_values field_types in List.iter - (fun ((v, ty) : V.typed_avalue * T.rty) -> assert (v.V.ty = ty)) + (fun ((v, ty) : V.typed_avalue * T.ty) -> assert (v.V.ty = ty)) fields_with_types (* Tuple case *) - | V.AAdt av, T.Adt (T.Tuple, generics) -> + | V.AAdt av, T.TAdt (T.Tuple, generics) -> assert (generics.regions = []); assert (generics.const_generics = []); assert (av.V.variant_id = None); @@ -558,10 +572,10 @@ let check_typing_invariant (ctx : C.eval_ctx) : unit = List.combine av.V.field_values generics.types in List.iter - (fun ((v, ty) : V.typed_avalue * T.rty) -> assert (v.V.ty = ty)) + (fun ((v, ty) : V.typed_avalue * T.ty) -> assert (v.V.ty = ty)) fields_with_types (* Assumed type case *) - | V.AAdt av, T.Adt (T.Assumed aty_id, generics) -> ( + | V.AAdt av, T.TAdt (T.TAssumed aty_id, generics) -> ( assert (av.V.variant_id = None); match ( aty_id, @@ -571,7 +585,7 @@ let check_typing_invariant (ctx : C.eval_ctx) : unit = generics.const_generics ) with (* Box *) - | T.Box, [ boxed_value ], [], [ boxed_ty ], [] -> + | T.TBox, [ boxed_value ], [], [ boxed_ty ], [] -> assert (boxed_value.V.ty = boxed_ty) | _ -> raise (Failure "Erroneous type")) | V.ABottom, _ -> (* Nothing to check *) () @@ -663,7 +677,8 @@ let check_typing_invariant (ctx : C.eval_ctx) : unit = ("Erroneous typing:" ^ "\n- raw value: " ^ V.show_typed_avalue atv ^ "\n- value: " ^ typed_avalue_to_string ctx atv - ^ "\n- type: " ^ rty_to_string ctx atv.V.ty)); + ^ "\n- type: " + ^ PA.ty_to_string ctx atv.V.ty)); raise (Failure "Erroneous typing")); (* Continue exploring to inspect the subterms *) super#visit_typed_avalue info atv @@ -674,7 +689,7 @@ let check_typing_invariant (ctx : C.eval_ctx) : unit = type proj_borrows_info = { abs_id : V.AbstractionId.id; regions : T.RegionId.Set.t; - proj_ty : T.rty; + proj_ty : T.rty; (** The regions shouldn't be erased *) as_shared_value : bool; (** True if the value is below a shared borrow *) } [@@deriving show] @@ -686,7 +701,7 @@ type proj_loans_info = { [@@deriving show] type sv_info = { - ty : T.rty; + ty : T.rty; (** The regions shouldn't be erased *) env_count : int; aproj_borrows : proj_borrows_info list; aproj_loans : proj_loans_info list; diff --git a/compiler/LlbcAst.ml b/compiler/LlbcAst.ml index 2db859b2f..9772671e6 100644 --- a/compiler/LlbcAst.ml +++ b/compiler/LlbcAst.ml @@ -2,16 +2,13 @@ open Types open Values include Charon.LlbcAst -type abs_region_group = (AbstractionId.id, RegionId.id) g_region_group -[@@deriving show] - -type abs_region_groups = (AbstractionId.id, RegionId.id) g_region_groups -[@@deriving show] +type abs_region_group = AbstractionId.id g_region_group [@@deriving show] +type abs_region_groups = abs_region_group list [@@deriving show] (** A function signature, after instantiation *) type inst_fun_sig = { regions_hierarchy : abs_region_groups; - trait_type_constraints : rtrait_type_constraint list; + trait_type_constraints : trait_type_constraint list; inputs : rty list; output : rty; } diff --git a/compiler/LlbcAstUtils.ml b/compiler/LlbcAstUtils.ml index 0ab4ed948..46b368512 100644 --- a/compiler/LlbcAstUtils.ml +++ b/compiler/LlbcAstUtils.ml @@ -4,14 +4,14 @@ include Charon.LlbcAstUtils let lookup_fun_sig (fun_id : fun_id) (fun_decls : fun_decl FunDeclId.Map.t) : fun_sig = match fun_id with - | Regular id -> (FunDeclId.Map.find id fun_decls).signature - | Assumed aid -> Assumed.get_assumed_fun_sig aid + | 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 - | Regular id -> (FunDeclId.Map.find id fun_decls).name - | Assumed aid -> Assumed.get_assumed_fun_name aid + | 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*. diff --git a/compiler/Print.ml b/compiler/Print.ml index 7f0d95ff7..dd24767e2 100644 --- a/compiler/Print.ml +++ b/compiler/Print.ml @@ -15,8 +15,7 @@ let bool_to_string (b : bool) : string = if b then "true" else "false" (** Pretty-printing for values *) module Values = struct type value_formatter = { - rvar_to_string : T.RegionVarId.id -> string; - r_to_string : T.RegionId.id -> string; + 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; @@ -30,33 +29,9 @@ module Values = struct T.TypeDeclId.id -> T.VariantId.id option -> string list option; } - let value_to_etype_formatter (fmt : value_formatter) : PT.etype_formatter = + let value_to_type_formatter (fmt : value_formatter) : PT.type_formatter = { - PT.r_to_string = PT.erased_region_to_string; - PT.type_var_id_to_string = fmt.type_var_id_to_string; - PT.type_decl_id_to_string = fmt.type_decl_id_to_string; - 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 value_to_rtype_formatter (fmt : value_formatter) : PT.rtype_formatter = - { - PT.r_to_string = PT.region_to_string fmt.r_to_string; - PT.type_var_id_to_string = fmt.type_var_id_to_string; - PT.type_decl_id_to_string = fmt.type_decl_id_to_string; - 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 value_to_stype_formatter (fmt : value_formatter) : PT.stype_formatter = - { - PT.r_to_string = PT.region_to_string fmt.rvar_to_string; + 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; @@ -72,17 +47,17 @@ module Values = struct let symbolic_value_id_to_string (id : V.SymbolicValueId.id) : string = "s@" ^ V.SymbolicValueId.to_string id - let symbolic_value_to_string (fmt : PT.rtype_formatter) - (sv : V.symbolic_value) : string = - symbolic_value_id_to_string sv.sv_id ^ " : " ^ PT.rty_to_string fmt sv.sv_ty + let symbolic_value_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.rty) : string = + (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 (value_to_rtype_formatter fmt) sv.sv_ty - ^ " <: " - ^ PT.ty_to_string (value_to_rtype_formatter fmt) rty + ^ PT.ty_to_string ty_fmt sv.sv_ty + ^ " <: " ^ PT.ty_to_string ty_fmt rty (* TODO: it may be a good idea to try to factorize this function with * typed_avalue_to_string. At some point we had done it, because [typed_value] @@ -90,18 +65,18 @@ module Values = struct * but then we removed this general type because it proved to be a bad idea. *) let rec typed_value_to_string (fmt : value_formatter) (v : V.typed_value) : string = - let ty_fmt : PT.etype_formatter = value_to_etype_formatter fmt in + let ty_fmt : PT.type_formatter = value_to_type_formatter fmt in match v.value with - | Literal cv -> PPV.literal_to_string cv - | Adt av -> ( + | VLiteral cv -> PPV.literal_to_string cv + | VAdt av -> ( let field_values = List.map (typed_value_to_string fmt) av.field_values in match v.ty with - | T.Adt (T.Tuple, _) -> + | T.TAdt (T.Tuple, _) -> (* Tuple *) "(" ^ String.concat ", " field_values ^ ")" - | T.Adt (T.AdtId def_id, _) -> + | T.TAdt (T.AdtId def_id, _) -> (* "Regular" ADT *) let adt_ident = match av.variant_id with @@ -123,11 +98,11 @@ module Values = struct let field_values = String.concat " " field_values in adt_ident ^ " { " ^ field_values ^ " }" else adt_ident - | T.Adt (T.Assumed aty, _) -> ( + | T.TAdt (T.TAssumed aty, _) -> ( (* Assumed type *) match (aty, field_values) with - | Box, [ bv ] -> "@Box(" ^ bv ^ ")" - | Array, _ -> + | TBox, [ bv ] -> "@Box(" ^ bv ^ ")" + | TArray, _ -> (* Happens when we aggregate values *) "@Array[" ^ String.concat ", " field_values ^ "]" | _ -> @@ -136,7 +111,7 @@ module Values = struct | Bottom -> "⊥ : " ^ PT.ty_to_string ty_fmt v.ty | Borrow bc -> borrow_content_to_string fmt bc | Loan lc -> loan_content_to_string fmt lc - | Symbolic s -> symbolic_value_to_string (value_to_rtype_formatter fmt) s + | Symbolic s -> symbolic_value_to_string ty_fmt s and borrow_content_to_string (fmt : value_formatter) (bc : V.borrow_content) : string = @@ -180,7 +155,7 @@ module Values = struct " (" ^ String.concat "," given_back ^ ") " in "⌊" - ^ symbolic_value_to_string (value_to_rtype_formatter fmt) sv + ^ symbolic_value_to_string (value_to_type_formatter fmt) sv ^ given_back ^ "⌋" | AProjBorrows (sv, rty) -> "(" ^ symbolic_value_proj_to_string fmt sv rty ^ ")" @@ -195,17 +170,17 @@ module Values = struct let rec typed_avalue_to_string (fmt : value_formatter) (v : V.typed_avalue) : string = - let ty_fmt : PT.rtype_formatter = value_to_rtype_formatter fmt in + let ty_fmt : PT.type_formatter = value_to_type_formatter fmt in match v.value with | AAdt av -> ( let field_values = List.map (typed_avalue_to_string fmt) av.field_values in match v.ty with - | T.Adt (T.Tuple, _) -> + | T.TAdt (T.Tuple, _) -> (* Tuple *) "(" ^ String.concat ", " field_values ^ ")" - | T.Adt (T.AdtId def_id, _) -> + | T.TAdt (T.AdtId def_id, _) -> (* "Regular" ADT *) let adt_ident = match av.variant_id with @@ -227,10 +202,10 @@ module Values = struct let field_values = String.concat " " field_values in adt_ident ^ " { " ^ field_values ^ " }" else adt_ident - | T.Adt (T.Assumed aty, _) -> ( + | T.TAdt (T.TAssumed aty, _) -> ( (* Assumed type *) match (aty, field_values) with - | Box, [ bv ] -> "@Box(" ^ bv ^ ")" + | TBox, [ bv ] -> "@Box(" ^ bv ^ ")" | _ -> raise (Failure "Inconsistent value")) | _ -> raise (Failure "Inconsistent typed value")) | ABottom -> "⊥ : " ^ PT.ty_to_string ty_fmt v.ty @@ -352,7 +327,7 @@ module Values = struct let inst_fun_sig_to_string (fmt : value_formatter) (sg : LlbcAst.inst_fun_sig) : string = (* TODO: print the trait type constraints? *) - let ty_fmt = value_to_rtype_formatter fmt in + let ty_fmt = value_to_type_formatter fmt in let ty_to_string = PT.ty_to_string ty_fmt in let inputs = @@ -376,23 +351,23 @@ module Contexts = struct let binder_to_string (bv : C.binder) : string = match bv with - | VarBinder b -> var_binder_to_string b - | DummyBinder bid -> dummy_var_id_to_string bid + | BVar b -> var_binder_to_string b + | BDummy bid -> dummy_var_id_to_string bid let env_elem_to_string (fmt : PV.value_formatter) (verbose : bool) (with_var_types : bool) (indent : string) (indent_incr : string) (ev : C.env_elem) : string = match ev with - | Var (var, tv) -> + | EBinding (var, tv) -> let bv = binder_to_string var in let ty = if with_var_types then - " : " ^ PT.ty_to_string (PV.value_to_etype_formatter fmt) tv.V.ty + " : " ^ PT.ty_to_string (PV.value_to_type_formatter fmt) tv.V.ty else "" in indent ^ bv ^ ty ^ " -> " ^ PV.typed_value_to_string fmt tv ^ " ;" - | Abs abs -> PV.abs_to_string fmt verbose indent indent_incr abs - | Frame -> raise (Failure "Can't print a Frame element") + | EAbs abs -> PV.abs_to_string fmt 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) (with_var_types : bool) (indent : string) (indent_incr : string) @@ -413,10 +388,10 @@ module Contexts = struct *) let filter_elem (ev : C.env_elem) : C.env_elem option = match ev with - | Var (VarBinder _, tv) -> + | EBinding (BVar _, tv) -> (* Not a dummy binding: check if the value is ⊥ *) if VU.is_bottom tv.value then None else Some ev - | Var (DummyBinder _, tv) -> + | 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 @@ -456,8 +431,7 @@ module Contexts = struct let ast_to_ctx_formatter (fmt : PA.ast_formatter) : ctx_formatter = { - PV.rvar_to_string = fmt.rvar_to_string; - PV.r_to_string = fmt.r_to_string; + 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; @@ -473,22 +447,11 @@ module Contexts = struct let ast_to_value_formatter (fmt : PA.ast_formatter) : PV.value_formatter = ast_to_ctx_formatter fmt - let ctx_to_etype_formatter (fmt : ctx_formatter) : PT.etype_formatter = - PV.value_to_etype_formatter fmt - - let ctx_to_rtype_formatter (fmt : ctx_formatter) : PT.rtype_formatter = - PV.value_to_rtype_formatter fmt - - let ctx_to_stype_formatter (fmt : ctx_formatter) : PT.stype_formatter = - PV.value_to_stype_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 rvar_to_string r = - (* In theory we shouldn't use rvar_to_string, but it can happen - when printing definitions for instance... *) - T.RegionVarId.to_string r - in - let r_to_string r = PT.region_id_to_string r 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 *) @@ -529,8 +492,7 @@ module Contexts = struct PT.type_ctx_to_adt_field_names_fun ctx.type_context.type_decls in { - rvar_to_string; - r_to_string; + region_id_to_string; type_var_id_to_string; type_decl_id_to_string; const_generic_var_id_to_string; @@ -566,8 +528,7 @@ module Contexts = struct in let trait_clause_id_to_string id = PT.trait_clause_id_to_pretty_string id in { - rvar_to_string = ctx_fmt.PV.rvar_to_string; - r_to_string = ctx_fmt.PV.r_to_string; + 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; @@ -593,7 +554,7 @@ module Contexts = struct match env with | [] -> if List.length curr_frame > 0 then curr_frame :: frames else frames - | Frame :: env' -> split_aux (curr_frame :: frames) [] env' + | EFrame :: env' -> split_aux (curr_frame :: frames) [] env' | ev :: env' -> split_aux frames (ev :: curr_frame) env' in let frames = split_aux [] [] env in @@ -613,9 +574,9 @@ module Contexts = struct List.iter (fun ev -> match ev with - | C.Var (DummyBinder _, _) -> num_dummies := !num_abs + 1 - | C.Var (VarBinder _, _) -> num_bindings := !num_bindings + 1 - | C.Abs _ -> num_abs := !num_abs + 1 + | C.EBinding (BDummy _, _) -> num_dummies := !num_abs + 1 + | C.EBinding (BVar _, _) -> num_bindings := !num_bindings + 1 + | C.EAbs _ -> num_abs := !num_abs + 1 | _ -> raise (Failure "Unreachable")) f; "\n# Frame " ^ string_of_int i ^ ":" ^ "\n- locals: " @@ -645,77 +606,32 @@ module PC = Contexts (* local module *) (** Pretty-printing for LLBC ASTs (functions based on an evaluation context) *) module EvalCtxLlbcAst = struct - let ety_to_string (ctx : C.eval_ctx) (t : T.ety) : string = + let 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_etype_formatter fmt in - PT.ety_to_string fmt t - - let rty_to_string (ctx : C.eval_ctx) (t : T.rty) : string = - let fmt = PC.eval_ctx_to_ctx_formatter ctx in - let fmt = PC.ctx_to_rtype_formatter fmt in - PT.rty_to_string fmt t - - let sty_to_string (ctx : C.eval_ctx) (t : T.sty) : string = - let fmt = PC.eval_ctx_to_ctx_formatter ctx in - let fmt = PC.ctx_to_stype_formatter fmt in - PT.sty_to_string fmt t + let fmt = PC.ctx_to_type_formatter fmt in + PT.ty_to_string fmt t 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_stype_formatter fmt in + let fmt = PC.ctx_to_type_formatter fmt in PT.generic_params_to_strings fmt x - let egeneric_args_to_string (ctx : C.eval_ctx) (x : T.egeneric_args) : string - = - let fmt = PC.eval_ctx_to_ctx_formatter ctx in - let fmt = PC.ctx_to_etype_formatter fmt in - PT.egeneric_args_to_string fmt x - - let rgeneric_args_to_string (ctx : C.eval_ctx) (x : T.rgeneric_args) : string - = - let fmt = PC.eval_ctx_to_ctx_formatter ctx in - let fmt = PC.ctx_to_rtype_formatter fmt in - PT.rgeneric_args_to_string fmt x - - let sgeneric_args_to_string (ctx : C.eval_ctx) (x : T.sgeneric_args) : string - = + 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_stype_formatter fmt in - PT.sgeneric_args_to_string fmt x + let fmt = PC.ctx_to_type_formatter fmt in + PT.generic_args_to_string fmt x - let etrait_ref_to_string (ctx : C.eval_ctx) (x : T.etrait_ref) : string = + 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_etype_formatter fmt in - PT.etrait_ref_to_string fmt x + let fmt = PC.ctx_to_type_formatter fmt in + PT.trait_ref_to_string fmt x - let rtrait_ref_to_string (ctx : C.eval_ctx) (x : T.rtrait_ref) : string = - let fmt = PC.eval_ctx_to_ctx_formatter ctx in - let fmt = PC.ctx_to_rtype_formatter fmt in - PT.rtrait_ref_to_string fmt x - - let strait_ref_to_string (ctx : C.eval_ctx) (x : T.strait_ref) : string = - let fmt = PC.eval_ctx_to_ctx_formatter ctx in - let fmt = PC.ctx_to_stype_formatter fmt in - PT.strait_ref_to_string fmt x - - let etrait_instance_id_to_string (ctx : C.eval_ctx) (x : T.etrait_instance_id) - : string = - let fmt = PC.eval_ctx_to_ctx_formatter ctx in - let fmt = PC.ctx_to_etype_formatter fmt in - PT.etrait_instance_id_to_string fmt x - - let rtrait_instance_id_to_string (ctx : C.eval_ctx) (x : T.rtrait_instance_id) - : string = - let fmt = PC.eval_ctx_to_ctx_formatter ctx in - let fmt = PC.ctx_to_rtype_formatter fmt in - PT.rtrait_instance_id_to_string fmt x - - let strait_instance_id_to_string (ctx : C.eval_ctx) (x : T.strait_instance_id) - : string = + 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_stype_formatter fmt in - PT.strait_instance_id_to_string fmt x + let fmt = PC.ctx_to_type_formatter fmt in + PT.trait_instance_id_to_string fmt x let borrow_content_to_string (ctx : C.eval_ctx) (bc : V.borrow_content) : string = @@ -743,7 +659,7 @@ module EvalCtxLlbcAst = struct let symbolic_value_to_string (ctx : C.eval_ctx) (sv : V.symbolic_value) : string = let fmt = PC.eval_ctx_to_ctx_formatter ctx in - let fmt = PC.ctx_to_rtype_formatter fmt in + let fmt = PC.ctx_to_type_formatter fmt in PV.symbolic_value_to_string fmt sv let typed_value_to_string (ctx : C.eval_ctx) (v : V.typed_value) : string = diff --git a/compiler/PrintPure.ml b/compiler/PrintPure.ml index ec75fcfd8..cd1562156 100644 --- a/compiler/PrintPure.ml +++ b/compiler/PrintPure.ml @@ -205,7 +205,7 @@ let type_id_to_string (fmt : type_formatter) (id : type_id) : string = match id with | AdtId id -> fmt.type_decl_id_to_string id | Tuple -> "" - | Assumed aty -> assumed_ty_to_string aty + | 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) : @@ -217,12 +217,12 @@ let const_generic_to_string (fmt : type_formatter) (cg : T.const_generic) : let rec ty_to_string (fmt : type_formatter) (inside : bool) (ty : ty) : string = match ty with - | Adt (id, generics) -> ( + | TAdt (id, generics) -> ( match id with | Tuple -> let generics = generic_args_to_strings fmt false generics in "(" ^ String.concat " * " generics ^ ")" - | AdtId _ | Assumed _ -> + | AdtId _ | TAssumed _ -> let generics = generic_args_to_strings fmt true generics in let generics_s = if generics = [] then "" else " " ^ String.concat " " generics @@ -230,7 +230,7 @@ let rec ty_to_string (fmt : type_formatter) (inside : bool) (ty : ty) : string = let ty_s = type_id_to_string fmt id ^ generics_s in if generics <> [] && inside then "(" ^ ty_s ^ ")" else ty_s) | TypeVar tv -> fmt.type_var_id_to_string tv - | Literal lty -> literal_type_to_string lty + | TLiteral lty -> literal_type_to_string lty | Arrow (arg_ty, ret_ty) -> let ty = ty_to_string fmt true arg_ty ^ " -> " ^ ty_to_string fmt false ret_ty @@ -384,7 +384,7 @@ let adt_variant_to_string (fmt : value_formatter) (adt_id : type_id) match variant_id with | Some vid -> fmt.adt_variant_to_string def_id vid | None -> fmt.type_decl_id_to_string def_id) - | Assumed aty -> ( + | TAssumed aty -> ( (* Assumed type *) match aty with | State | Array | Slice | Str | RawPtr _ -> @@ -419,7 +419,7 @@ let adt_field_to_string (fmt : value_formatter) (adt_id : type_id) match fields with | None -> FieldId.to_string field_id | Some fields -> FieldId.nth fields field_id) - | Assumed aty -> ( + | TAssumed aty -> ( (* Assumed type *) match aty with | State | Fuel | Array | Slice | Str -> @@ -437,10 +437,10 @@ let adt_g_value_to_string (fmt : value_formatter) (field_values : 'v list) (ty : ty) : string = let field_values = List.map value_to_string field_values in match ty with - | Adt (Tuple, _) -> + | TAdt (Tuple, _) -> (* Tuple *) "(" ^ String.concat ", " field_values ^ ")" - | Adt (AdtId def_id, _) -> + | TAdt (AdtId def_id, _) -> (* "Regular" ADT *) let adt_ident = match variant_id with @@ -462,7 +462,7 @@ let adt_g_value_to_string (fmt : value_formatter) let field_values = String.concat " " field_values in adt_ident ^ " { " ^ field_values ^ " }" else adt_ident - | Adt (Assumed aty, _) -> ( + | TAdt (TAssumed aty, _) -> ( (* Assumed type *) match aty with | State | RawPtr _ -> @@ -585,8 +585,8 @@ let regular_fun_id_to_string (fmt : ast_formatter) (fun_id : fun_id) : string = | FromLlbc (fid, lp_id, rg_id) -> let f = match fid with - | FunId (Regular fid) -> fmt.fun_decl_id_to_string fid - | FunId (Assumed fid) -> llbc_assumed_fun_id_to_string fid + | FunId (FRegular fid) -> fmt.fun_decl_id_to_string 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 @@ -664,7 +664,7 @@ let rec texpression_to_string (fmt : ast_formatter) (inside : bool) in let bl = if fields = [] then "" else "\n" ^ indent in "{" ^ s ^ String.concat "" fields ^ bl ^ "}" - | Assumed Array -> + | TAssumed Array -> let fields = List.map (fun (_, fe) -> diff --git a/compiler/Pure.ml b/compiler/Pure.ml index e6a3dab5e..ffbd1f097 100644 --- a/compiler/Pure.ml +++ b/compiler/Pure.ml @@ -64,6 +64,8 @@ type mutability = Mut | Const [@@deriving show, ord] - [State]: the type of the state, when using state-error monads. Note that this state is opaque to Aeneas (the user can define it, or leave it as assumed) + + TODO: add a prefix "T" *) type assumed_ty = | State @@ -144,7 +146,7 @@ class virtual ['self] mapreduce_type_id_base = fun _ x -> (x, self#zero) end -type type_id = AdtId of type_decl_id | Tuple | Assumed of assumed_ty +type type_id = AdtId of type_decl_id | Tuple | TAssumed of assumed_ty [@@deriving show, ord, @@ -190,7 +192,6 @@ class ['self] iter_ty_base = object (_self : 'self) inherit [_] iter_type_id inherit! [_] T.iter_const_generic - inherit! [_] PV.iter_literal_type method visit_type_var_id : 'env -> type_var_id -> unit = fun _ _ -> () method visit_trait_decl_id : 'env -> trait_decl_id -> unit = fun _ _ -> () method visit_trait_impl_id : 'env -> trait_impl_id -> unit = fun _ _ -> () @@ -207,7 +208,6 @@ class ['self] map_ty_base = object (_self : 'self) inherit [_] map_type_id inherit! [_] T.map_const_generic - inherit! [_] PV.map_literal_type method visit_type_var_id : 'env -> type_var_id -> type_var_id = fun _ x -> x method visit_trait_decl_id : 'env -> trait_decl_id -> trait_decl_id = @@ -228,7 +228,6 @@ class virtual ['self] reduce_ty_base = object (self : 'self) inherit [_] reduce_type_id inherit! [_] T.reduce_const_generic - inherit! [_] PV.reduce_literal_type method visit_type_var_id : 'env -> type_var_id -> 'a = fun _ _ -> self#zero method visit_trait_decl_id : 'env -> trait_decl_id -> 'a = @@ -249,7 +248,6 @@ class virtual ['self] mapreduce_ty_base = object (self : 'self) inherit [_] mapreduce_type_id inherit! [_] T.mapreduce_const_generic - inherit! [_] PV.mapreduce_literal_type method visit_type_var_id : 'env -> type_var_id -> type_var_id * 'a = fun _ x -> (x, self#zero) @@ -270,7 +268,7 @@ class virtual ['self] mapreduce_ty_base = end type ty = - | Adt of type_id * generic_args + | TAdt of type_id * generic_args (** {!Adt} encodes ADTs and tuples and assumed types. TODO: what about the ended regions? (ADTs may be parameterized @@ -279,7 +277,7 @@ type ty = such "partial" ADTs. *) | TypeVar of type_var_id - | Literal of literal_type + | TLiteral of literal_type | Arrow of ty * ty | TraitType of trait_ref * generic_args * string (** The string is for the name of the associated type *) diff --git a/compiler/PureMicroPasses.ml b/compiler/PureMicroPasses.ml index f3e6cbe29..d62a028e7 100644 --- a/compiler/PureMicroPasses.ml +++ b/compiler/PureMicroPasses.ml @@ -791,7 +791,7 @@ let expression_contains_child_call_in_all_paths (ctx : trans_ctx) let id0 = match id0 with | FunId fun_id -> fun_id - | TraitMethod (_, _, fun_decl_id) -> Regular fun_decl_id + | TraitMethod (_, _, fun_decl_id) -> FRegular fun_decl_id in LlbcAstUtils.lookup_fun_sig id0 ctx.fun_ctx.fun_decls in @@ -1527,7 +1527,7 @@ let eliminate_box_functions (ctx : trans_ctx) (def : fun_decl) : fun_decl = * could have: [box_new f x]) * *) match fun_id with - | Fun (FromLlbc (FunId (Assumed aid), _lp_id, rg_id)) -> ( + | Fun (FromLlbc (FunId (FAssumed aid), _lp_id, rg_id)) -> ( match (aid, rg_id) with | BoxNew, _ -> assert (rg_id = None); @@ -1541,7 +1541,7 @@ let eliminate_box_functions (ctx : trans_ctx) (def : fun_decl) : fun_decl = | ArrayRepeat | SliceLen ), _ ) -> super#visit_texpression env e) - | Fun (FromLlbc (FunId (Regular fid), _lp_id, rg_id)) -> ( + | Fun (FromLlbc (FunId (FRegular fid), _lp_id, rg_id)) -> ( (* Lookup the function name *) let def = FunDeclId.Map.find fid ctx.fun_ctx.fun_decls in match @@ -2050,7 +2050,7 @@ let filter_loop_inputs (transl : pure_fun_translation list) : let inputs_set = VarId.Set.of_list (List.map var_get_id inputs_prefix) in assert (Option.is_some decl.loop_id); - let fun_id = (E.Regular decl.def_id, decl.loop_id) in + let fun_id = (E.FRegular decl.def_id, decl.loop_id) in let set_used vid = used := List.map (fun (vid', b) -> (vid', b || vid = vid')) !used @@ -2134,7 +2134,7 @@ let filter_loop_inputs (transl : pure_fun_translation list) : (* We then apply the filtering to all the function definitions at once *) let filter_in_one (decl : fun_decl) : fun_decl = (* Filter the function signature *) - let fun_id = (E.Regular decl.def_id, decl.loop_id) in + let fun_id = (E.FRegular decl.def_id, decl.loop_id) in let decl = match FunLoopIdMap.find_opt fun_id !used_map with | None -> (* Nothing to filter *) decl diff --git a/compiler/PureTypeCheck.ml b/compiler/PureTypeCheck.ml index 2ad942bbb..f8b5de6aa 100644 --- a/compiler/PureTypeCheck.ml +++ b/compiler/PureTypeCheck.ml @@ -22,7 +22,7 @@ let get_adt_field_types (type_decls : type_decl TypeDeclId.Map.t) (* "Regular" ADT *) let def = TypeDeclId.Map.find def_id type_decls in type_decl_get_instantiated_fields_types def variant_id generics - | Assumed aty -> ( + | TAssumed aty -> ( (* Assumed type *) match aty with | State -> @@ -63,8 +63,8 @@ type tc_ctx = { let check_literal (v : literal) (ty : literal_type) : unit = match (ty, v) with - | Integer int_ty, PV.Scalar sv -> assert (int_ty = sv.PV.int_ty) - | Bool, Bool _ | Char, Char _ -> () + | TInteger int_ty, PV.VScalar sv -> assert (int_ty = sv.PV.int_ty) + | TBool, VBool _ | TChar, VChar _ -> () | _ -> raise (Failure "Inconsistent type") let rec check_typed_pattern (ctx : tc_ctx) (v : typed_pattern) : tc_ctx = @@ -156,7 +156,7 @@ let rec check_texpression (ctx : tc_ctx) (e : texpression) : unit = let field_tys, adt_ty = destruct_arrows e.ty in assert (expected_field_tys = field_tys); match adt_ty with - | Adt (type_id, generics) -> + | TAdt (type_id, generics) -> assert (type_id = id.adt_id); assert (generics = qualif.generics) | _ -> raise (Failure "Unreachable"))) @@ -174,7 +174,7 @@ let rec check_texpression (ctx : tc_ctx) (e : texpression) : unit = check_texpression ctx scrut; match switch_body with | If (e_then, e_else) -> - assert (scrut.ty = Literal Bool); + assert (scrut.ty = TLiteral TBool); assert (e_then.ty = e.ty); assert (e_else.ty = e.ty); check_texpression ctx e_then; @@ -219,7 +219,7 @@ let rec check_texpression (ctx : tc_ctx) (e : texpression) : unit = assert (expected_field_ty = fe.ty); check_texpression ctx fe) supd.updates - | Assumed Array -> + | TAssumed Array -> let expected_field_ty = Collections.List.to_cons_nil adt_generics.types in diff --git a/compiler/PureUtils.ml b/compiler/PureUtils.ml index 3aeabffec..5e46d551e 100644 --- a/compiler/PureUtils.ml +++ b/compiler/PureUtils.ml @@ -64,14 +64,14 @@ let dest_arrow_ty (ty : ty) : ty * ty = let compute_literal_type (cv : literal) : literal_type = match cv with - | PV.Scalar sv -> Integer sv.PV.int_ty - | Bool _ -> Bool - | Char _ -> Char + | PV.VScalar sv -> TInteger sv.PV.int_ty + | VBool _ -> TBool + | VChar _ -> TChar let var_get_id (v : var) : VarId.id = v.id let mk_typed_pattern_from_literal (cv : literal) : typed_pattern = - let ty = Literal (compute_literal_type cv) in + let ty = TLiteral (compute_literal_type cv) in { value = PatConstant cv; ty } let mk_let (monadic : bool) (lv : typed_pattern) (re : texpression) @@ -232,7 +232,7 @@ let is_const (e : texpression) : bool = let ty_as_adt (ty : ty) : type_id * generic_args = match ty with - | Adt (id, generics) -> (id, generics) + | TAdt (id, generics) -> (id, generics) | _ -> raise (Failure "Unreachable") (** Remove the external occurrences of {!Meta} *) @@ -340,7 +340,7 @@ let opt_destruct_function_call (e : texpression) : let opt_destruct_result (ty : ty) : ty option = match ty with - | Adt (Assumed Result, generics) -> + | TAdt (TAssumed Result, generics) -> assert (generics.const_generics = []); assert (generics.trait_refs = []); Some (Collections.List.to_cons_nil generics.types) @@ -350,7 +350,7 @@ let destruct_result (ty : ty) : ty = Option.get (opt_destruct_result ty) let opt_destruct_tuple (ty : ty) : ty list option = match ty with - | Adt (Tuple, generics) -> + | TAdt (Tuple, generics) -> assert (generics.const_generics = []); assert (generics.trait_refs = []); Some generics.types @@ -408,7 +408,7 @@ let iter_switch_body_branches (f : texpression -> unit) (sb : switch_body) : let mk_switch (scrut : texpression) (sb : switch_body) : texpression = (* Sanity check: the scrutinee has the proper type *) (match sb with - | If (_, _) -> assert (scrut.ty = Literal Bool) + | If (_, _) -> assert (scrut.ty = TLiteral TBool) | Match branches -> List.iter (fun (b : match_branch) -> assert (b.pat.ty = scrut.ty)) @@ -427,10 +427,10 @@ let mk_switch (scrut : texpression) (sb : switch_body) : texpression = let mk_simpl_tuple_ty (tys : ty list) : ty = match tys with | [ ty ] -> ty - | _ -> Adt (Tuple, mk_generic_args_from_types tys) + | _ -> TAdt (Tuple, mk_generic_args_from_types tys) -let mk_bool_ty : ty = Literal Bool -let mk_unit_ty : ty = Adt (Tuple, empty_generic_args) +let mk_bool_ty : ty = TLiteral TBool +let mk_unit_ty : ty = TAdt (Tuple, empty_generic_args) let mk_unit_rvalue : texpression = let id = AdtCons { adt_id = Tuple; variant_id = None } in @@ -474,7 +474,7 @@ let mk_simpl_tuple_pattern (vl : typed_pattern list) : typed_pattern = | [ v ] -> v | _ -> let tys = List.map (fun (v : typed_pattern) -> v.ty) vl in - let ty = Adt (Tuple, mk_generic_args_from_types tys) in + let ty = TAdt (Tuple, mk_generic_args_from_types tys) in let value = PatAdt { variant_id = None; field_values = vl } in { value; ty } @@ -485,7 +485,7 @@ let mk_simpl_tuple_texpression (vl : texpression list) : texpression = | _ -> (* Compute the types of the fields, and the type of the tuple constructor *) let tys = List.map (fun (v : texpression) -> v.ty) vl in - let ty = Adt (Tuple, mk_generic_args_from_types tys) in + let ty = TAdt (Tuple, mk_generic_args_from_types tys) in let ty = mk_arrows tys ty in (* Construct the tuple constructor qualifier *) let id = AdtCons { adt_id = Tuple; variant_id = None } in @@ -501,40 +501,40 @@ let mk_adt_pattern (adt_ty : ty) (variant_id : VariantId.id option) let ty_as_integer (t : ty) : T.integer_type = match t with - | Literal (Integer int_ty) -> int_ty + | TLiteral (TInteger int_ty) -> int_ty | _ -> raise (Failure "Unreachable") let ty_as_literal (t : ty) : T.literal_type = - match t with Literal ty -> ty | _ -> raise (Failure "Unreachable") + match t with TLiteral ty -> ty | _ -> raise (Failure "Unreachable") -let mk_state_ty : ty = Adt (Assumed State, empty_generic_args) +let mk_state_ty : ty = TAdt (TAssumed State, empty_generic_args) let mk_result_ty (ty : ty) : ty = - Adt (Assumed Result, mk_generic_args_from_types [ ty ]) + TAdt (TAssumed Result, mk_generic_args_from_types [ ty ]) -let mk_error_ty : ty = Adt (Assumed Error, empty_generic_args) -let mk_fuel_ty : ty = Adt (Assumed Fuel, empty_generic_args) +let mk_error_ty : ty = TAdt (TAssumed Error, empty_generic_args) +let mk_fuel_ty : ty = TAdt (TAssumed Fuel, empty_generic_args) let mk_error (error : VariantId.id) : texpression = let ty = mk_error_ty in - let id = AdtCons { adt_id = Assumed Error; variant_id = Some error } in + let id = AdtCons { adt_id = TAssumed Error; variant_id = Some error } in let qualif = { id; generics = empty_generic_args } in let e = Qualif qualif in { e; ty } let unwrap_result_ty (ty : ty) : ty = match ty with - | Adt - (Assumed Result, { types = [ ty ]; const_generics = []; trait_refs = [] }) + | TAdt + (TAssumed Result, { types = [ ty ]; const_generics = []; trait_refs = [] }) -> ty | _ -> raise (Failure "not a result type") let mk_result_fail_texpression (error : texpression) (ty : ty) : texpression = let type_args = [ ty ] in - let ty = Adt (Assumed Result, mk_generic_args_from_types type_args) in + let ty = TAdt (TAssumed Result, mk_generic_args_from_types type_args) in let id = - AdtCons { adt_id = Assumed Result; variant_id = Some result_fail_id } + AdtCons { adt_id = TAssumed Result; variant_id = Some result_fail_id } in let qualif = { id; generics = mk_generic_args_from_types type_args } in let cons_e = Qualif qualif in @@ -549,9 +549,9 @@ let mk_result_fail_texpression_with_error_id (error : VariantId.id) (ty : ty) : let mk_result_return_texpression (v : texpression) : texpression = let type_args = [ v.ty ] in - let ty = Adt (Assumed Result, mk_generic_args_from_types type_args) in + let ty = TAdt (TAssumed Result, mk_generic_args_from_types type_args) in let id = - AdtCons { adt_id = Assumed Result; variant_id = Some result_return_id } + AdtCons { adt_id = TAssumed Result; variant_id = Some result_return_id } in let qualif = { id; generics = mk_generic_args_from_types type_args } in let cons_e = Qualif qualif in @@ -562,7 +562,7 @@ let mk_result_return_texpression (v : texpression) : texpression = (** Create a [Fail err] pattern which captures the error *) let mk_result_fail_pattern (error_pat : pattern) (ty : ty) : typed_pattern = let error_pat : typed_pattern = { value = error_pat; ty = mk_error_ty } in - let ty = Adt (Assumed Result, mk_generic_args_from_types [ ty ]) in + let ty = TAdt (TAssumed Result, mk_generic_args_from_types [ ty ]) in let value = PatAdt { variant_id = Some result_fail_id; field_values = [ error_pat ] } in @@ -574,7 +574,7 @@ let mk_result_fail_pattern_ignore_error (ty : ty) : typed_pattern = mk_result_fail_pattern error_pat ty let mk_result_return_pattern (v : typed_pattern) : typed_pattern = - let ty = Adt (Assumed Result, mk_generic_args_from_types [ v.ty ]) in + let ty = TAdt (TAssumed Result, mk_generic_args_from_types [ v.ty ]) in let value = PatAdt { variant_id = Some result_return_id; field_values = [ v ] } in diff --git a/compiler/ReorderDecls.ml b/compiler/ReorderDecls.ml index 10b68da32..c82d625f0 100644 --- a/compiler/ReorderDecls.ml +++ b/compiler/ReorderDecls.ml @@ -46,8 +46,8 @@ let compute_body_fun_deps (e : texpression) : FunIdSet.t = | Pure _ -> () | FromLlbc (fid, lp_id, rg_id) -> ( match fid with - | FunId (Assumed _) -> () - | TraitMethod (_, _, fid) | FunId (Regular fid) -> + | FunId (FAssumed _) -> () + | TraitMethod (_, _, fid) | FunId (FRegular fid) -> let id = { def_id = fid; lp_id; rg_id } in ids := FunIdSet.add id !ids)) end diff --git a/compiler/Substitute.ml b/compiler/Substitute.ml index 23f618e2e..b4eee9f8c 100644 --- a/compiler/Substitute.ml +++ b/compiler/Substitute.ml @@ -9,20 +9,20 @@ module E = Expressions module A = LlbcAst module C = Contexts -type ('r1, 'r2) subst = { - r_subst : 'r1 -> 'r2; - ty_subst : T.TypeVarId.id -> 'r2 T.ty; +type subst = { + r_subst : T.region -> T.region; + ty_subst : T.TypeVarId.id -> T.ty; cg_subst : T.ConstGenericVarId.id -> T.const_generic; (** Substitution from *local* trait clause to trait instance *) - tr_subst : T.TraitClauseId.id -> 'r2 T.trait_instance_id; + tr_subst : T.TraitClauseId.id -> T.trait_instance_id; (** Substitution for the [Self] trait instance *) - tr_self : 'r2 T.trait_instance_id; + tr_self : T.trait_instance_id; } -let ty_substitute_visitor (subst : ('r1, 'r2) subst) = +let st_substitute_visitor (subst : subst) = object - inherit [_] T.map_ty - method visit_'r _ r = subst.r_subst r + inherit [_] A.map_statement + method! visit_region _ r = subst.r_subst r method! visit_TypeVar _ id = subst.ty_subst id method! visit_type_var_id _ _ = @@ -43,25 +43,30 @@ let ty_substitute_visitor (subst : ('r1, 'r2) subst) = **IMPORTANT**: this doesn't normalize the types. *) -let ty_substitute (subst : ('r1, 'r2) subst) (ty : 'r1 T.ty) : 'r2 T.ty = - let visitor = ty_substitute_visitor subst in +let ty_substitute (subst : subst) (ty : T.ty) : T.ty = + let visitor = st_substitute_visitor subst in visitor#visit_ty () ty (** **IMPORTANT**: this doesn't normalize the types. *) -let trait_ref_substitute (subst : ('r1, 'r2) subst) (tr : 'r1 T.trait_ref) : - 'r2 T.trait_ref = - let visitor = ty_substitute_visitor subst in +let trait_ref_substitute (subst : subst) (tr : T.trait_ref) : T.trait_ref = + let visitor = st_substitute_visitor subst in visitor#visit_trait_ref () tr (** **IMPORTANT**: this doesn't normalize the types. *) -let generic_args_substitute (subst : ('r1, 'r2) subst) (g : 'r1 T.generic_args) - : 'r2 T.generic_args = - let visitor = ty_substitute_visitor subst in +let trait_instance_id_substitute (subst : subst) (tr : T.trait_instance_id) : + T.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 visitor = st_substitute_visitor subst in visitor#visit_generic_args () g -let erase_regions_subst : ('r, T.erased_region) subst = +let erase_regions_subst : subst = { - r_subst = (fun _ -> T.Erased); + r_subst = (fun _ -> T.RErased); ty_subst = (fun vid -> T.TypeVar vid); cg_subst = (fun id -> T.ConstGenericVar id); tr_subst = (fun id -> T.Clause id); @@ -69,11 +74,18 @@ let erase_regions_subst : ('r, T.erased_region) subst = } (** Convert an {!T.rty} to an {!T.ety} by erasing the region variables *) -let erase_regions (ty : 'r T.ty) : T.ety = ty_substitute erase_regions_subst ty +let erase_regions (ty : T.ty) : T.ty = ty_substitute erase_regions_subst ty -let trait_ref_erase_regions (tr : 'r T.trait_ref) : T.etrait_ref = +let trait_ref_erase_regions (tr : T.trait_ref) : T.trait_ref = trait_ref_substitute erase_regions_subst tr +let trait_instance_id_erase_regions (tr : T.trait_instance_id) : + T.trait_instance_id = + trait_instance_id_substitute erase_regions_subst tr + +let generic_args_erase_regions (tr : T.generic_args) : T.generic_args = + generic_args_substitute erase_regions_subst tr + (** Generate fresh regions for region variables. Return the list of new regions and appropriate substitutions from the @@ -83,60 +95,62 @@ let trait_ref_erase_regions (tr : 'r T.trait_ref) : T.etrait_ref = *) let fresh_regions_with_substs (region_vars : T.region_var list) : T.RegionId.id list - * (T.RegionVarId.id -> T.RegionId.id) - * (T.RegionVarId.id T.region -> T.RegionId.id T.region) = + * (T.RegionId.id -> T.RegionId.id) + * (T.region -> T.region) = (* Generate fresh regions *) let fresh_region_ids = List.map (fun _ -> C.fresh_region_id ()) region_vars in (* Generate the map from region var ids to regions *) let ls = List.combine region_vars fresh_region_ids in let rid_map = List.fold_left - (fun mp ((k : T.region_var), v) -> T.RegionVarId.Map.add k.T.index v mp) - T.RegionVarId.Map.empty ls + (fun mp ((k : T.region_var), v) -> T.RegionId.Map.add k.T.index v mp) + T.RegionId.Map.empty ls in (* Generate the substitution from region var id to region *) - let rid_subst id = T.RegionVarId.Map.find id rid_map in + let rid_subst id = T.RegionId.Map.find id rid_map in (* Generate the substitution from region to region *) - let r_subst r = - match r with T.Static -> T.Static | T.Var id -> T.Var (rid_subst id) + let r_subst (r : T.region) = + match r with + | T.RStatic | T.RErased -> r + | T.RVar id -> T.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.ety) +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.etrait_instance_id) - (tr_self : T.etrait_instance_id) (ty : 'r T.ty) : T.ety = - let r_subst (_ : 'r) : T.erased_region = T.Erased in + (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 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.RegionVarId.id list) - (regions : 'r T.region list) : T.RegionVarId.id T.region -> 'r T.region = +let make_region_subst (var_ids : T.RegionId.id list) (regions : T.region list) : + T.region -> T.region = let ls = List.combine var_ids regions in let mp = List.fold_left - (fun mp (k, v) -> T.RegionVarId.Map.add k v mp) - T.RegionVarId.Map.empty ls + (fun mp (k, v) -> T.RegionId.Map.add k v mp) + T.RegionId.Map.empty ls in fun r -> match r with - | T.Static -> T.Static - | T.Var id -> T.RegionVarId.Map.find id mp + | T.RStatic | T.RErased -> r + | T.RVar id -> T.RegionId.Map.find id mp let make_region_subst_from_vars (vars : T.region_var list) - (regions : 'r T.region list) : T.RegionVarId.id T.region -> 'r T.region = + (regions : T.region list) : T.region -> T.region = make_region_subst (List.map (fun (x : T.region_var) -> x.T.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 : 'r T.ty list) : - T.TypeVarId.id -> 'r T.ty = +let make_type_subst (var_ids : T.TypeVarId.id list) (tys : T.ty list) : + T.TypeVarId.id -> T.ty = let ls = List.combine var_ids tys in let mp = List.fold_left @@ -145,8 +159,8 @@ let make_type_subst (var_ids : T.TypeVarId.id list) (tys : 'r T.ty list) : in fun id -> T.TypeVarId.Map.find id mp -let make_type_subst_from_vars (vars : T.type_var list) (tys : 'r T.ty list) : - T.TypeVarId.id -> 'r T.ty = +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 (** Create a const generic substitution from a list of const generic variable ids and a list of @@ -170,7 +184,7 @@ let make_const_generic_subst_from_vars (vars : T.const_generic_var list) (** 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 : 'r T.trait_ref list) : T.TraitClauseId.id -> 'r T.trait_instance_id = + (trs : T.trait_ref list) : T.TraitClauseId.id -> T.trait_instance_id = let ls = List.combine clause_ids trs in let mp = List.fold_left @@ -180,15 +194,13 @@ let make_trait_subst (clause_ids : T.TraitClauseId.id list) fun id -> T.TraitClauseId.Map.find id mp let make_trait_subst_from_clauses (clauses : T.trait_clause list) - (trs : 'r T.trait_ref list) : T.TraitClauseId.id -> 'r T.trait_instance_id = + (trs : T.trait_ref list) : T.TraitClauseId.id -> T.trait_instance_id = make_trait_subst (List.map (fun (x : T.trait_clause) -> x.T.clause_id) clauses) trs -let make_subst_from_generics (params : T.generic_params) - (args : 'r T.region T.generic_args) - (tr_self : 'r T.region T.trait_instance_id) : - (T.region_var_id T.region, 'r T.region) subst = +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 cg_subst = @@ -200,36 +212,12 @@ let make_subst_from_generics (params : T.generic_params) in { r_subst; ty_subst; cg_subst; tr_subst; tr_self } -let make_subst_from_generics_no_regions : - 'r. - T.generic_params -> - 'r T.generic_args -> - 'r T.trait_instance_id -> - (T.region_var_id T.region, 'r) subst = - fun params args tr_self -> - let r_subst _ = raise (Failure "Unexpected region") in - let ty_subst = make_type_subst_from_vars params.T.types args.T.types in - let cg_subst = - make_const_generic_subst_from_vars params.T.const_generics - args.T.const_generics - in - let tr_subst = - make_trait_subst_from_clauses params.T.trait_clauses args.T.trait_refs - in - { r_subst; ty_subst; cg_subst; tr_subst; tr_self } - -let make_esubst_from_generics (params : T.generic_params) - (generics : T.egeneric_args) (tr_self : T.etrait_instance_id) = - let r_subst _ = T.Erased in - let ty_subst = make_type_subst_from_vars params.types generics.T.types in - let cg_subst = - make_const_generic_subst_from_vars params.const_generics - generics.T.const_generics - in - let tr_subst = - make_trait_subst_from_clauses params.trait_clauses generics.T.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 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) } (** Instantiate the type variables in an ADT definition, and return, for every variant, the list of the types of its fields. @@ -237,8 +225,8 @@ let make_esubst_from_generics (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_rtypes (def : T.type_decl) - (generics : T.rgeneric_args) : (T.VariantId.id option * T.rty list) list = +let type_decl_get_instantiated_variants_fields_types (def : T.type_decl) + (generics : T.generic_args) : (T.VariantId.id option * T.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 @@ -266,9 +254,9 @@ let type_decl_get_instantiated_variants_fields_rtypes (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_rtypes (def : T.type_decl) - (opt_variant_id : T.VariantId.id option) (generics : T.rgeneric_args) : - T.rty list = +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 = (* For now, check that there are no clauses - otherwise we might need to normalize the types *) assert (def.generics.trait_clauses = []); @@ -284,11 +272,11 @@ let type_decl_get_instantiated_field_rtypes (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_rtypes (ctx : C.eval_ctx) +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.rgeneric_args) : T.rty list = + (generics : T.generic_args) : T.ty list = let def = C.ctx_lookup_type_decl ctx def_id in - type_decl_get_instantiated_field_rtypes def opt_variant_id generics + type_decl_get_instantiated_field_types def opt_variant_id generics (** Return the types of the properly instantiated ADT value (note that here, ADT is understood in its broad meaning: ADT, assumed value or tuple). @@ -296,122 +284,55 @@ let ctx_adt_get_instantiated_field_rtypes (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_rtypes (ctx : C.eval_ctx) - (adt : V.adt_value) (id : T.type_id) (generics : T.rgeneric_args) : - T.rty list = +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 + = match id with | T.AdtId id -> (* Retrieve the types of the fields *) - ctx_adt_get_instantiated_field_rtypes ctx id adt.V.variant_id generics + ctx_adt_get_instantiated_field_types ctx id adt.V.variant_id generics | T.Tuple -> assert (generics.regions = []); generics.types - | T.Assumed aty -> ( + | T.TAssumed aty -> ( match aty with - | T.Box -> + | T.TBox -> assert (generics.regions = []); assert (List.length generics.types = 1); assert (generics.const_generics = []); generics.types - | T.Array | T.Slice | T.Str -> + | T.TArray | T.TSlice | T.TStr -> (* Those types don't have fields *) raise (Failure "Unreachable")) -(** Instantiate the type variables in an ADT definition, and return the list - of types of the fields for the chosen variant. - - **IMPORTANT**: this function doesn't normalize the types, you may want to - use the [AssociatedTypes] equivalent instead. -*) -let type_decl_get_instantiated_field_etypes (def : T.type_decl) - (opt_variant_id : T.VariantId.id option) (generics : T.egeneric_args) : - T.ety 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.erased_region T.trait_instance_id = - T.UnknownTrait __FUNCTION__ - in - let { r_subst = _; ty_subst; cg_subst; tr_subst; tr_self } = - make_esubst_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 : T.field) -> - erase_regions_substitute_types ty_subst cg_subst tr_subst tr_self - f.T.field_ty) - fields - -(** Return the types of the properly instantiated ADT's variant, provided a - context. - - **IMPORTANT**: this function doesn't normalize the types, you may want to - use the [AssociatedTypes] equivalent instead. - *) -let ctx_adt_get_instantiated_field_etypes (ctx : C.eval_ctx) - (def_id : T.TypeDeclId.id) (opt_variant_id : T.VariantId.id option) - (generics : T.egeneric_args) : T.ety list = - let def = C.ctx_lookup_type_decl ctx def_id in - type_decl_get_instantiated_field_etypes def opt_variant_id generics - -let statement_substitute_visitor - (subst : (T.erased_region, T.erased_region) subst) = - (* Keep in synch with [ty_substitute_visitor] *) - object - inherit [_] A.map_statement - method! visit_'r _ r = subst.r_subst r - method! visit_TypeVar _ id = subst.ty_subst id - - method! visit_type_var_id _ _ = - (* We should never get here because we reimplemented [visit_TypeVar] *) - raise (Failure "Unexpected") - - method! visit_ConstGenericVar _ id = subst.cg_subst id - - method! visit_const_generic_var_id _ _ = - (* We should never get here because we reimplemented [visit_Var] *) - raise (Failure "Unexpected") - - method! visit_Clause _ id = subst.tr_subst id - method! visit_Self _ = subst.tr_self - end - (** Apply a type substitution to a place *) -let place_substitute (subst : (T.erased_region, T.erased_region) subst) - (p : E.place) : E.place = +let place_substitute (subst : subst) (p : E.place) : E.place = (* There is in fact nothing to do *) - (statement_substitute_visitor subst)#visit_place () p + (st_substitute_visitor subst)#visit_place () p (** Apply a type substitution to an operand *) -let operand_substitute (subst : (T.erased_region, T.erased_region) subst) - (op : E.operand) : E.operand = - (statement_substitute_visitor subst)#visit_operand () op +let operand_substitute (subst : subst) (op : E.operand) : E.operand = + (st_substitute_visitor subst)#visit_operand () op (** Apply a type substitution to an rvalue *) -let rvalue_substitute (subst : (T.erased_region, T.erased_region) subst) - (rv : E.rvalue) : E.rvalue = - (statement_substitute_visitor subst)#visit_rvalue () rv +let rvalue_substitute (subst : subst) (rv : E.rvalue) : E.rvalue = + (st_substitute_visitor subst)#visit_rvalue () rv (** Apply a type substitution to an assertion *) -let assertion_substitute (subst : (T.erased_region, T.erased_region) subst) - (a : A.assertion) : A.assertion = - (statement_substitute_visitor subst)#visit_assertion () a +let assertion_substitute (subst : subst) (a : A.assertion) : A.assertion = + (st_substitute_visitor subst)#visit_assertion () a (** Apply a type substitution to a call *) -let call_substitute (subst : (T.erased_region, T.erased_region) subst) - (call : A.call) : A.call = - (statement_substitute_visitor subst)#visit_call () call +let call_substitute (subst : subst) (call : A.call) : A.call = + (st_substitute_visitor subst)#visit_call () call (** Apply a type substitution to a statement *) -let statement_substitute (subst : (T.erased_region, T.erased_region) subst) - (st : A.statement) : A.statement = - (statement_substitute_visitor subst)#visit_statement () st +let statement_substitute (subst : subst) (st : A.statement) : A.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 : (T.erased_region, T.erased_region) subst) (body : A.fun_body) : +let fun_body_substitute_in_body (subst : subst) (body : A.fun_body) : A.var list * A.statement = let locals = List.map @@ -421,10 +342,10 @@ let fun_body_substitute_in_body let body = statement_substitute subst body.body in (locals, body) -let trait_type_constraint_substitute (subst : ('r1, 'r2) subst) - (ttc : 'r1 T.trait_type_constraint) : 'r2 T.trait_type_constraint = +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 - let visitor = ty_substitute_visitor subst 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 @@ -435,22 +356,24 @@ let trait_type_constraint_substitute (subst : ('r1, 'r2) subst) **IMPORTANT:** this function doesn't normalize the types. *) let substitute_signature (asubst : T.RegionGroupId.id -> V.AbstractionId.id) - (r_subst : T.RegionVarId.id -> T.RegionId.id) - (ty_subst : T.TypeVarId.id -> T.rty) + (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.rtrait_instance_id) - (tr_self : T.rtrait_instance_id) (sg : A.fun_sig) : A.inst_fun_sig = - let r_subst' (r : T.RegionVarId.id T.region) : T.RegionId.id T.region = - match r with T.Static -> T.Static | T.Var rid -> T.Var (r_subst rid) + (tr_subst : T.TraitClauseId.id -> T.trait_instance_id) + (tr_self : T.trait_instance_id) (sg : A.fun_sig) : 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) 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_var_group) : A.abs_region_group = + let subst_region_group (rg : T.region_group) : A.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 } + ({ id; regions; parents } : A.abs_region_group) in let regions_hierarchy = List.map subst_region_group sg.A.regions_hierarchy in let trait_type_constraints = @@ -461,9 +384,9 @@ let substitute_signature (asubst : T.RegionGroupId.id -> V.AbstractionId.id) { A.inputs; output; regions_hierarchy; trait_type_constraints } (** Substitute variable identifiers in a type *) -let ty_substitute_ids (ty_subst : T.TypeVarId.id -> T.TypeVarId.id) - (cg_subst : T.ConstGenericVarId.id -> T.ConstGenericVarId.id) (ty : 'r T.ty) - : 'r T.ty = +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 visitor = object @@ -476,80 +399,39 @@ let ty_substitute_ids (ty_subst : T.TypeVarId.id -> T.TypeVarId.id) visitor#visit_ty () ty -(* This visitor is a mess... - - We want to write a class which visits abstractions, values, etc. *and their - types* to substitute identifiers. - - The issue is that we derive two specialized types (ety and rty) from a - polymorphic type (ty). Because of this, there are typing issues with - [visit_'r] if we define a class which visits objects of types [ety] and [rty] - while inheriting a class which visit [ty]... -*) let subst_ids_visitor (r_subst : T.RegionId.id -> T.RegionId.id) - (rvsubst : T.RegionVarId.id -> T.RegionVarId.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_rty = - object - inherit [_] T.map_ty - - method visit_'r _ r = - match r with T.Static -> T.Static | T.Var rid -> T.Var (r_subst rid) - - method! visit_type_var_id _ id = ty_subst id - method! visit_const_generic_var_id _ id = cg_subst id - end - in - - let visitor = - object (self : 'self) - inherit [_] C.map_env - method! visit_borrow_id _ bid = bsubst bid - method! visit_loan_id _ bid = bsubst bid - method! visit_ety _ ty = ty_substitute_ids ty_subst cg_subst ty - method! visit_rty env ty = subst_rty#visit_ty env ty - method! visit_symbolic_value_id _ id = ssubst id - - (** We *do* visit meta-values *) - method! visit_msymbolic_value env sv = self#visit_symbolic_value env sv - - (** We *do* visit meta-values *) - method! visit_mvalue env v = self#visit_typed_value env v - - method! visit_region_id _ id = r_subst id - method! visit_region_var_id _ id = rvsubst id - method! visit_abstraction_id _ id = asubst id - end - in - - object - method visit_ety (x : T.ety) : T.ety = visitor#visit_ety () x - method visit_rty (x : T.rty) : T.rty = visitor#visit_rty () x - - method visit_typed_value (x : V.typed_value) : V.typed_value = - visitor#visit_typed_value () x - - method visit_typed_avalue (x : V.typed_avalue) : V.typed_avalue = - visitor#visit_typed_avalue () x - - method visit_abs (x : V.abs) : V.abs = visitor#visit_abs () x - method visit_env (env : C.env) : C.env = visitor#visit_env () env + object (self : 'self) + inherit [_] C.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 + method! visit_borrow_id _ bid = bsubst bid + method! visit_loan_id _ bid = bsubst bid + method! visit_symbolic_value_id _ id = ssubst id + + (** We *do* visit meta-values *) + method! visit_msymbolic_value env sv = self#visit_symbolic_value env sv + + (** We *do* visit meta-values *) + method! visit_mvalue env v = self#visit_typed_value env v + + method! visit_abstraction_id _ id = asubst id end let typed_value_subst_ids (r_subst : T.RegionId.id -> T.RegionId.id) - (rvsubst : T.RegionVarId.id -> T.RegionVarId.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 asubst _ = raise (Failure "Unreachable") in - (subst_ids_visitor r_subst rvsubst ty_subst cg_subst ssubst bsubst asubst) - #visit_typed_value v + 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 = @@ -558,61 +440,57 @@ let typed_value_subst_rids (r_subst : T.RegionId.id -> T.RegionId.id) (fun x -> x) (fun x -> x) (fun x -> x) - (fun x -> x) v let typed_avalue_subst_ids (r_subst : T.RegionId.id -> T.RegionId.id) - (rvsubst : T.RegionVarId.id -> T.RegionVarId.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 asubst _ = raise (Failure "Unreachable") in - (subst_ids_visitor r_subst rvsubst ty_subst cg_subst ssubst bsubst asubst) - #visit_typed_avalue v + 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) - (rvsubst : T.RegionVarId.id -> T.RegionVarId.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 = - (subst_ids_visitor r_subst rvsubst ty_subst cg_subst ssubst bsubst asubst) - #visit_abs x + 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) - (rvsubst : T.RegionVarId.id -> T.RegionVarId.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 = - (subst_ids_visitor r_subst rvsubst ty_subst cg_subst ssubst bsubst asubst) - #visit_env x + 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 asubst _ = raise (Failure "Unreachable") in - (subst_ids_visitor r_subst - (fun x -> x) - (fun x -> x) - (fun x -> x) - (fun x -> x) - (fun x -> x) - asubst) - #visit_typed_avalue - x + let vis = + subst_ids_visitor r_subst + (fun x -> x) + (fun x -> x) + (fun x -> x) + (fun x -> x) + asubst + in + vis#visit_typed_avalue () x let env_subst_rids (r_subst : T.RegionId.id -> T.RegionId.id) (x : C.env) : C.env = - (subst_ids_visitor r_subst - (fun x -> x) - (fun x -> x) - (fun x -> x) - (fun x -> x) - (fun x -> x) - (fun x -> x)) - #visit_env - x + let vis = + subst_ids_visitor r_subst + (fun x -> x) + (fun x -> x) + (fun x -> x) + (fun x -> x) + (fun x -> x) + in + vis#visit_env () x diff --git a/compiler/SymbolicAst.ml b/compiler/SymbolicAst.ml index 4df8fec75..927544b22 100644 --- a/compiler/SymbolicAst.ml +++ b/compiler/SymbolicAst.ml @@ -43,7 +43,7 @@ type call = { borrows (we need to perform lookups). *) abstractions : V.AbstractionId.id list; - generics : T.egeneric_args; + generics : T.generic_args; args : V.typed_value list; args_places : mplace option list; (** Meta information *) dest : V.symbolic_value; @@ -65,30 +65,22 @@ 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] -(** Ancestor for {!expression} iter visitor *) +(** Ancestor for {!expression} iter visitor. + + We could make it inherit the visitor for {!eval_ctx}, but in all the uses + of this visitor we don't need to explore {!eval_ctx}, so we make it inherit + the abstraction visitors instead. + *) class ['self] iter_expression_base = object (self : 'self) - inherit [_] VisitorsRuntime.iter + inherit [_] V.iter_abs method visit_eval_ctx : 'env -> Contexts.eval_ctx -> unit = fun _ _ -> () - method visit_typed_value : 'env -> V.typed_value -> unit = fun _ _ -> () method visit_call : 'env -> call -> unit = fun _ _ -> () - method visit_abs : 'env -> V.abs -> unit = fun _ _ -> () method visit_loop_id : 'env -> V.loop_id -> unit = fun _ _ -> () - method visit_variant_id : 'env -> variant_id -> unit = fun _ _ -> () - - method visit_const_generic_var_id : 'env -> T.const_generic_var_id -> unit = - fun _ _ -> () - - method visit_symbolic_value_id : 'env -> V.symbolic_value_id -> unit = - fun _ _ -> () - - method visit_symbolic_value : 'env -> V.symbolic_value -> unit = - fun _ _ -> () method visit_region_group_id : 'env -> T.RegionGroupId.id -> unit = fun _ _ -> () - method visit_global_decl_id : 'env -> global_decl_id -> unit = fun _ _ -> () method visit_mplace : 'env -> mplace -> unit = fun _ _ -> () method visit_meta : 'env -> meta -> unit = fun _ _ -> () @@ -115,14 +107,8 @@ class ['self] iter_expression_base = fun env s -> V.SymbolicValueId.Set.iter (self#visit_symbolic_value_id env) s - method visit_integer_type : 'env -> T.integer_type -> unit = fun _ _ -> () - method visit_scalar_value : 'env -> V.scalar_value -> unit = fun _ _ -> () - method visit_symbolic_expansion : 'env -> V.symbolic_expansion -> unit = fun _ _ -> () - - method visit_etrait_ref : 'env -> T.etrait_ref -> unit = fun _ _ -> () - method visit_egeneric_args : 'env -> T.egeneric_args -> unit = fun _ _ -> () end (** **Rem.:** here, {!expression} is not at all equivalent to the expressions @@ -224,7 +210,7 @@ and loop = { fresh_svalues : V.symbolic_value_id_set; (** The symbolic values introduced by the loop fixed-point *) rg_to_given_back_tys : - ((T.RegionId.Set.t * T.rty list) T.RegionGroupId.Map.t[@opaque]); + ((T.RegionId.Set.t * T.ty list) T.RegionGroupId.Map.t[@opaque]); (** The map from region group ids to the types of the values given back by the corresponding loop abstractions. *) @@ -254,13 +240,13 @@ and expansion = (* 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 = - | SingleValue of V.typed_value (** Regular case *) - | Array of V.typed_value list + | VaSingleValue of V.typed_value (** Regular case *) + | VaArray of V.typed_value list (** This is used when introducing array aggregates *) - | ConstGenericValue of T.const_generic_var_id + | VaConstGenericValue of T.const_generic_var_id (** This is used when evaluating a const generic value: in the interpreter, we introduce a fresh symbolic value. *) - | TraitConstValue of T.etrait_ref * T.egeneric_args * string + | VaTraitConstValue of T.trait_ref * T.generic_args * string (** A trait constant value *) [@@deriving show, diff --git a/compiler/SymbolicToPure.ml b/compiler/SymbolicToPure.ml index 2ce8c706c..977554382 100644 --- a/compiler/SymbolicToPure.ml +++ b/compiler/SymbolicToPure.ml @@ -213,14 +213,12 @@ let bs_ctx_to_ast_formatter (ctx : bs_ctx) : Print.Ast.ast_formatter = 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 rvar_to_string = Print.Types.region_var_id_to_string in - let r_to_string = Print.Types.region_id_to_string in + 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 { - Print.Values.rvar_to_string; - r_to_string; + 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; @@ -242,30 +240,29 @@ let bs_ctx_to_pp_ast_formatter (ctx : bs_ctx) : PrintPure.ast_formatter = ctx.trait_decls_ctx ctx.trait_impls_ctx generics.types generics.const_generics -let ctx_egeneric_args_to_string (ctx : bs_ctx) (args : T.egeneric_args) : string - = +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_etype_formatter fmt in - Print.PT.egeneric_args_to_string fmt args + let fmt = Print.PC.ctx_to_type_formatter fmt in + Print.PT.generic_args_to_string fmt args 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_rtype_formatter fmt in + let fmt = Print.PC.ctx_to_type_formatter fmt in Print.PV.symbolic_value_to_string fmt 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 ty_to_string (ctx : bs_ctx) (ty : ty) : string = +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 rty_to_string (ctx : bs_ctx) (ty : T.rty) : string = +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_rtype_formatter fmt in - Print.PT.rty_to_string fmt ty + let fmt = Print.PC.ctx_to_type_formatter fmt in + Print.PT.ty_to_string fmt ty let type_decl_to_string (ctx : bs_ctx) (def : type_decl) : string = let type_decls = ctx.type_context.llbc_type_decls in @@ -343,13 +340,13 @@ let bs_ctx_lookup_llbc_fun_decl (id : A.FunDeclId.id) (ctx : bs_ctx) : (* TODO: move *) let bs_ctx_lookup_local_function_sig (def_id : A.FunDeclId.id) (back_id : T.RegionGroupId.id option) (ctx : bs_ctx) : fun_sig = - let id = (E.Regular def_id, back_id) in + let id = (E.FRegular def_id, back_id) in (RegularFunIdNotLoopMap.find id ctx.fun_context.fun_sigs).sg (* Some generic translation functions (we need to translate different "flavours" - of types: sty, forward types, backward types, etc.) *) -let rec translate_generic_args (translate_ty : 'r T.ty -> ty) - (generics : 'r T.generic_args) : generic_args = + of types: forward types, backward types, etc.) *) +let rec translate_generic_args (translate_ty : T.ty -> ty) + (generics : T.generic_args) : generic_args = (* We ignore the regions: if they didn't cause trouble for the symbolic execution, then everything's fine *) let types = List.map translate_ty generics.types in @@ -359,7 +356,7 @@ let rec translate_generic_args (translate_ty : 'r T.ty -> ty) in { types; const_generics; trait_refs } -and translate_trait_ref (translate_ty : 'r T.ty -> ty) (tr : 'r T.trait_ref) : +and translate_trait_ref (translate_ty : T.ty -> ty) (tr : T.trait_ref) : trait_ref = let trait_id = translate_trait_instance_id translate_ty tr.trait_id in let generics = translate_generic_args translate_ty tr.generics in @@ -368,13 +365,13 @@ and translate_trait_ref (translate_ty : 'r T.ty -> ty) (tr : 'r T.trait_ref) : in { trait_id; generics; trait_decl_ref } -and translate_trait_decl_ref (translate_ty : 'r T.ty -> ty) - (tr : 'r T.trait_decl_ref) : trait_decl_ref = +and translate_trait_decl_ref (translate_ty : T.ty -> ty) (tr : T.trait_decl_ref) + : trait_decl_ref = let decl_generics = translate_generic_args translate_ty tr.decl_generics in { trait_decl_id = tr.trait_decl_id; decl_generics } -and translate_trait_instance_id (translate_ty : 'r T.ty -> ty) - (id : 'r T.trait_instance_id) : trait_instance_id = +and translate_trait_instance_id (translate_ty : T.ty -> ty) + (id : T.trait_instance_id) : trait_instance_id = let translate_trait_instance_id = translate_trait_instance_id translate_ty in match id with | T.Self -> Self @@ -393,19 +390,20 @@ and translate_trait_instance_id (translate_ty : 'r T.ty -> ty) | FnPointer _ -> raise (Failure "TODO") | UnknownTrait s -> raise (Failure ("Unknown trait found: " ^ s)) -let rec translate_sty (ty : T.sty) : ty = +(** Translate a signature type - TODO: factor out the different translation functions *) +let rec translate_sty (ty : T.ty) : ty = let translate = translate_sty in match ty with - | T.Adt (type_id, generics) -> ( + | T.TAdt (type_id, generics) -> ( let generics = translate_sgeneric_args generics in match type_id with - | T.AdtId adt_id -> Adt (AdtId adt_id, generics) + | T.AdtId adt_id -> TAdt (AdtId adt_id, generics) | T.Tuple -> assert (generics.const_generics = []); mk_simpl_tuple_ty generics.types - | T.Assumed aty -> ( + | T.TAssumed aty -> ( match aty with - | T.Box -> ( + | T.TBox -> ( (* Eliminate the boxes *) match generics.types with | [ ty ] -> ty @@ -414,31 +412,31 @@ let rec translate_sty (ty : T.sty) : ty = (Failure "Box/vec/option type with incorrect number of arguments") ) - | T.Array -> Adt (Assumed Array, generics) - | T.Slice -> Adt (Assumed Slice, generics) - | T.Str -> Adt (Assumed Str, generics))) + | T.TArray -> TAdt (TAssumed Array, generics) + | T.TSlice -> TAdt (TAssumed Slice, generics) + | T.TStr -> TAdt (TAssumed Str, generics))) | TypeVar vid -> TypeVar vid - | Literal ty -> Literal ty + | TLiteral ty -> TLiteral ty | Never -> raise (Failure "Unreachable") | Ref (_, rty, _) -> translate rty | RawPtr (ty, rkind) -> let mut = match rkind with Mut -> Mut | Shared -> Const in let ty = translate ty in let generics = { types = [ ty ]; const_generics = []; trait_refs = [] } in - Adt (Assumed (RawPtr mut), generics) + TAdt (TAssumed (RawPtr mut), generics) | TraitType (trait_ref, generics, type_name) -> let trait_ref = translate_strait_ref trait_ref in let generics = translate_sgeneric_args generics in TraitType (trait_ref, generics, type_name) | Arrow _ -> raise (Failure "TODO") -and translate_sgeneric_args (generics : T.sgeneric_args) : generic_args = +and translate_sgeneric_args (generics : T.generic_args) : generic_args = translate_generic_args translate_sty generics -and translate_strait_ref (tr : T.strait_ref) : trait_ref = +and translate_strait_ref (tr : T.trait_ref) : trait_ref = translate_trait_ref translate_sty tr -and translate_strait_instance_id (id : T.strait_instance_id) : trait_instance_id +and translate_strait_instance_id (id : T.trait_instance_id) : trait_instance_id = translate_trait_instance_id translate_sty id @@ -447,7 +445,7 @@ let translate_trait_clause (clause : T.trait_clause) : trait_clause = let generics = translate_sgeneric_args generics in { clause_id; trait_id; generics } -let translate_strait_type_constraint (ttc : T.strait_type_constraint) : +let translate_strait_type_constraint (ttc : T.trait_type_constraint) : trait_type_constraint = let { T.trait_ref; generics; type_name; ty } = ttc in let trait_ref = translate_strait_ref trait_ref in @@ -509,38 +507,43 @@ let translate_type_decl (def : T.type_decl) : type_decl = let translate_type_id (id : T.type_id) : type_id = match id with | AdtId adt_id -> AdtId adt_id - | T.Assumed aty -> + | T.TAssumed aty -> let aty = match aty with - | T.Array -> Array - | T.Slice -> Slice - | T.Str -> Str - | T.Box -> + | T.TArray -> Array + | T.TSlice -> Slice + | T.TStr -> Str + | T.TBox -> (* Boxes have to be eliminated: this type id shouldn't be translated *) raise (Failure "Unreachable") in - Assumed aty + TAssumed aty | T.Tuple -> Tuple (** Translate a type, seen as an input/output of a forward function - (preserve all borrows, etc.) + (preserve all borrows, etc.). + + Remark: it doesn't matter whether the types has regions or erased regions + (both cases happen, actually). + + TODO: factor out the various translation functions. *) -let rec translate_fwd_ty (type_infos : TA.type_infos) (ty : 'r T.ty) : ty = +let rec translate_fwd_ty (type_infos : TA.type_infos) (ty : T.ty) : ty = let translate = translate_fwd_ty type_infos in match ty with - | T.Adt (type_id, generics) -> ( + | T.TAdt (type_id, generics) -> ( let t_generics = translate_fwd_generic_args type_infos generics in (* Eliminate boxes and simplify tuples *) match type_id with - | AdtId _ | T.Assumed (T.Array | T.Slice | T.Str) -> + | AdtId _ | T.TAssumed (T.TArray | T.TSlice | T.TStr) -> let type_id = translate_type_id type_id in - Adt (type_id, t_generics) + TAdt (type_id, t_generics) | Tuple -> (* Note that if there is exactly one type, [mk_simpl_tuple_ty] is the identity *) mk_simpl_tuple_ty t_generics.types - | T.Assumed T.Box -> ( + | T.TAssumed T.TBox -> ( (* We eliminate boxes *) (* No general parametricity for now *) assert ( @@ -557,13 +560,13 @@ let rec translate_fwd_ty (type_infos : TA.type_infos) (ty : 'r T.ty) : ty = parameter"))) | TypeVar vid -> TypeVar vid | Never -> raise (Failure "Unreachable") - | Literal lty -> Literal lty + | TLiteral lty -> TLiteral lty | Ref (_, rty, _) -> translate rty | RawPtr (ty, rkind) -> let mut = match rkind with Mut -> Mut | Shared -> Const in let ty = translate ty in let generics = { types = [ ty ]; const_generics = []; trait_refs = [] } in - Adt (Assumed (RawPtr mut), generics) + TAdt (TAssumed (RawPtr mut), generics) | TraitType (trait_ref, generics, type_name) -> let trait_ref = translate_fwd_trait_ref type_infos trait_ref in let generics = translate_fwd_generic_args type_infos generics in @@ -571,25 +574,25 @@ let rec translate_fwd_ty (type_infos : TA.type_infos) (ty : 'r T.ty) : ty = | Arrow _ -> raise (Failure "TODO") and translate_fwd_generic_args (type_infos : TA.type_infos) - (generics : 'r T.generic_args) : generic_args = + (generics : T.generic_args) : generic_args = translate_generic_args (translate_fwd_ty type_infos) generics -and translate_fwd_trait_ref (type_infos : TA.type_infos) (tr : 'r T.trait_ref) : +and translate_fwd_trait_ref (type_infos : TA.type_infos) (tr : T.trait_ref) : trait_ref = translate_trait_ref (translate_fwd_ty type_infos) tr and translate_fwd_trait_instance_id (type_infos : TA.type_infos) - (id : 'r T.trait_instance_id) : trait_instance_id = + (id : T.trait_instance_id) : trait_instance_id = translate_trait_instance_id (translate_fwd_ty type_infos) id (** Simply calls [translate_fwd_ty] *) -let ctx_translate_fwd_ty (ctx : bs_ctx) (ty : 'r T.ty) : ty = +let ctx_translate_fwd_ty (ctx : bs_ctx) (ty : T.ty) : ty = let type_infos = ctx.type_context.type_infos in translate_fwd_ty type_infos ty (** Simply calls [translate_fwd_generic_args] *) -let ctx_translate_fwd_generic_args (ctx : bs_ctx) (generics : 'r T.generic_args) - : generic_args = +let ctx_translate_fwd_generic_args (ctx : bs_ctx) (generics : T.generic_args) : + generic_args = let type_infos = ctx.type_context.type_infos in translate_fwd_generic_args type_infos generics @@ -600,20 +603,21 @@ let ctx_translate_fwd_generic_args (ctx : bs_ctx) (generics : 'r T.generic_args) [inside_mut]: are we inside a mutable borrow? *) let rec translate_back_ty (type_infos : TA.type_infos) - (keep_region : 'r -> bool) (inside_mut : bool) (ty : 'r T.ty) : ty option = + (keep_region : T.region -> bool) (inside_mut : bool) (ty : T.ty) : ty option + = let translate = translate_back_ty type_infos keep_region inside_mut in (* A small helper for "leave" types *) let wrap ty = if inside_mut then Some ty else None in match ty with - | T.Adt (type_id, generics) -> ( + | T.TAdt (type_id, generics) -> ( match type_id with - | T.AdtId _ | Assumed (T.Array | T.Slice | T.Str) -> + | T.AdtId _ | TAssumed (T.TArray | T.TSlice | T.TStr) -> let type_id = translate_type_id type_id in if inside_mut then (* We do not want to filter anything, so we translate the generics as "forward" types *) let generics = translate_fwd_generic_args type_infos generics in - Some (Adt (type_id, generics)) + Some (TAdt (type_id, generics)) else (* If not inside a mutable reference: check if at least one of the generics contains a mutable reference (i.e., is not @@ -624,9 +628,9 @@ let rec translate_back_ty (type_infos : TA.type_infos) let types = List.filter_map translate generics.types in if types <> [] then let generics = translate_fwd_generic_args type_infos generics in - Some (Adt (type_id, generics)) + Some (TAdt (type_id, generics)) else None - | Assumed T.Box -> ( + | TAssumed T.TBox -> ( (* Don't accept ADTs (which are not tuples) with borrows for now *) assert (not (TypesUtils.ty_has_borrows type_infos ty)); (* Eliminate the box *) @@ -647,7 +651,7 @@ let rec translate_back_ty (type_infos : TA.type_infos) Some (mk_simpl_tuple_ty tys_t))) | TypeVar vid -> wrap (TypeVar vid) | Never -> raise (Failure "Unreachable") - | Literal lty -> wrap (Literal lty) + | TLiteral lty -> wrap (TLiteral lty) | Ref (r, rty, rkind) -> ( match rkind with | T.Shared -> @@ -673,7 +677,7 @@ let rec translate_back_ty (type_infos : TA.type_infos) (** Simply calls [translate_back_ty] *) let ctx_translate_back_ty (ctx : bs_ctx) (keep_region : 'r -> bool) - (inside_mut : bool) (ty : 'r T.ty) : ty option = + (inside_mut : bool) (ty : T.ty) : ty option = let type_infos = ctx.type_context.type_infos in translate_back_ty type_infos keep_region inside_mut ty @@ -682,7 +686,7 @@ let mk_type_check_ctx (ctx : bs_ctx) : PureTypeCheck.tc_ctx = T.ConstGenericVarId.Map.of_list (List.map (fun (cg : T.const_generic_var) -> - (cg.index, ctx_translate_fwd_ty ctx (T.Literal cg.ty))) + (cg.index, ctx_translate_fwd_ty ctx (T.TLiteral cg.ty))) ctx.sg.generics.const_generics) in let env = VarId.Map.empty in @@ -807,7 +811,7 @@ let get_fun_effect_info (fun_infos : FA.fun_info A.FunDeclId.Map.t) (fun_id : A.fun_id_or_trait_method_ref) (lid : V.LoopId.id option) (gid : T.RegionGroupId.id option) : fun_effect_info = match fun_id with - | TraitMethod (_, _, fid) | FunId (Regular fid) -> + | TraitMethod (_, _, fid) | FunId (FRegular fid) -> let info = A.FunDeclId.Map.find fid fun_infos in let stateful_group = info.stateful in let stateful = @@ -820,7 +824,7 @@ let get_fun_effect_info (fun_infos : FA.fun_info A.FunDeclId.Map.t) can_diverge = info.can_diverge; is_rec = info.is_rec || Option.is_some lid; } - | FunId (Assumed aid) -> + | FunId (FAssumed aid) -> assert (lid = None); { can_fail = Assumed.assumed_fun_can_fail aid; @@ -861,21 +865,21 @@ let translate_fun_sig (decls_ctx : C.decls_ctx) (fun_id : A.fun_id) (* Create the context *) let ctx = let region_groups = - List.map (fun (g : T.region_var_group) -> g.id) sg.regions_hierarchy + List.map (fun (g : T.region_group) -> g.id) sg.regions_hierarchy in let ctx = InterpreterUtils.initialize_eval_context decls_ctx region_groups sg.generics.types sg.generics.const_generics in (* Compute the normalization map for the *sty* types and add it to the context *) - AssociatedTypes.ctx_add_norm_trait_stypes_from_preds ctx + AssociatedTypes.ctx_add_norm_trait_types_from_preds ctx sg.preds.trait_type_constraints in (* Normalize the signature *) let sg = let ({ A.inputs; output; _ } : A.fun_sig) = sg in - let norm = AssociatedTypes.ctx_normalize_sty ctx 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 } @@ -893,14 +897,14 @@ let translate_fun_sig (decls_ctx : C.decls_ctx) (fun_id : A.fun_id) * so just check that there aren't parent regions *) assert (T.RegionGroupId.Set.is_empty parents); (* Small helper to translate types for backward functions *) - let translate_back_ty_for_gid (gid : T.RegionGroupId.id) : T.sty -> ty option - = + let translate_back_ty_for_gid (gid : T.RegionGroupId.id) : T.ty -> ty option = let rg = T.RegionGroupId.nth sg.regions_hierarchy gid in - let regions = T.RegionVarId.Set.of_list rg.regions in + let regions = T.RegionId.Set.of_list rg.regions in let keep_region r = match r with - | T.Static -> raise Unimplemented - | T.Var r -> T.RegionVarId.Set.mem r regions + | T.RStatic -> raise Unimplemented + | T.RErased -> raise (Failure "Unexpected erased region") + | T.RVar r -> T.RegionId.Set.mem r regions in let inside_mut = false in translate_back_ty type_infos keep_region inside_mut @@ -1042,7 +1046,7 @@ let bs_ctx_fresh_state_var (ctx : bs_ctx) : bs_ctx * typed_pattern = (* Return *) (ctx, state_pat) -let fresh_var_llbc_ty (basename : string option) (ty : 'r T.ty) (ctx : bs_ctx) : +let fresh_var_llbc_ty (basename : string option) (ty : T.ty) (ctx : bs_ctx) : bs_ctx * var = (* Generate the fresh variable *) let id, var_counter = VarId.fresh ctx.var_counter in @@ -1106,7 +1110,7 @@ let lookup_var_for_symbolic_value (sv : V.symbolic_value) (ctx : bs_ctx) : var = (** Peel boxes as long as the value is of the form [Box] *) let rec unbox_typed_value (v : V.typed_value) : V.typed_value = match (v.value, v.ty) with - | V.Adt av, T.Adt (T.Assumed T.Box, _) -> ( + | V.VAdt av, T.TAdt (T.TAssumed T.TBox, _) -> ( match av.field_values with | [ bv ] -> unbox_typed_value bv | _ -> raise (Failure "Unreachable")) @@ -1145,13 +1149,13 @@ let rec typed_value_to_texpression (ctx : bs_ctx) (ectx : C.eval_ctx) (* Translate the value *) let value = match v.value with - | V.Literal cv -> { e = Const cv; ty } - | Adt av -> ( + | V.VLiteral cv -> { e = Const cv; ty } + | VAdt av -> ( let variant_id = av.variant_id in let field_values = List.map translate av.field_values in (* Eliminate the tuple wrapper if it is a tuple with exactly one field *) match v.ty with - | T.Adt (T.Tuple, _) -> + | T.TAdt (T.Tuple, _) -> assert (variant_id = None); mk_simpl_tuple_texpression field_values | _ -> @@ -1229,7 +1233,7 @@ let rec typed_avalue_to_consumed (ctx : bs_ctx) (ectx : C.eval_ctx) (* For now, only tuples can contain borrows *) let adt_id, _ = TypesUtils.ty_as_adt av.ty in match adt_id with - | T.AdtId _ | T.Assumed (T.Box | T.Array | T.Slice | T.Str) -> + | T.AdtId _ | T.TAssumed (T.TBox | T.TArray | T.TSlice | T.TStr) -> assert (field_values = []); None | T.Tuple -> @@ -1374,7 +1378,7 @@ let rec typed_avalue_to_given_back (mp : mplace option) (av : V.typed_avalue) * vector value upon visiting the "abstraction borrow" node *) let adt_id, _ = TypesUtils.ty_as_adt av.ty in match adt_id with - | T.AdtId _ | T.Assumed (T.Box | T.Array | T.Slice | T.Str) -> + | T.AdtId _ | T.TAssumed (T.TBox | T.TArray | T.TSlice | T.TStr) -> assert (field_values = []); (ctx, None) | T.Tuple -> @@ -1645,7 +1649,7 @@ and translate_function_call (call : S.call) (e : S.expression) (ctx : bs_ctx) : log#ldebug (lazy ("translate_function_call:\n" - ^ ctx_egeneric_args_to_string ctx call.generics)); + ^ ctx_generic_args_to_string ctx call.generics)); (* Translate the function call *) let generics = ctx_translate_fwd_generic_args ctx call.generics in let args = @@ -1845,11 +1849,12 @@ and translate_end_abstraction_synth_input (ectx : C.eval_ctx) (abs : V.abs) ("translate_end_abstraction_synth_input:" ^ "\n\n- given back variables types:\n" ^ Print.list_to_string - (fun (v : var) -> ty_to_string ctx v.ty) + (fun (v : var) -> pure_ty_to_string ctx v.ty) given_back_variables ^ "\n\n- consumed values:\n" ^ Print.list_to_string - (fun e -> texpression_to_string ctx e ^ " : " ^ ty_to_string ctx e.ty) + (fun e -> + texpression_to_string ctx e ^ " : " ^ pure_ty_to_string ctx e.ty) consumed_values ^ "\n")); @@ -1948,7 +1953,8 @@ and translate_end_abstraction_fun_call (ectx : C.eval_ctx) (abs : V.abs) ^ "\n- inst_sg.inputs (" ^ string_of_int (List.length inst_sg.inputs) ^ "): " - ^ String.concat ", " (List.map (ty_to_string ctx) inst_sg.inputs))); + ^ String.concat ", " + (List.map (pure_ty_to_string ctx) inst_sg.inputs))); List.iter (fun (x, ty) -> assert ((x : texpression).ty = ty)) (List.combine inputs inst_sg.inputs); @@ -2070,8 +2076,9 @@ and translate_end_abstraction_synth_ret (ectx : C.eval_ctx) (abs : V.abs) log#ldebug (lazy ("\n- given_back ty: " - ^ ty_to_string ctx given_back.ty - ^ "\n- sig input ty: " ^ ty_to_string ctx input.ty)); + ^ pure_ty_to_string ctx given_back.ty + ^ "\n- sig input ty: " + ^ pure_ty_to_string ctx input.ty)); assert (given_back.ty = input.ty)) given_back_inputs; (* Translate the next expression *) @@ -2098,7 +2105,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.Regular ctx.fun_decl.A.def_id in + let fun_id = E.FRegular ctx.fun_decl.A.def_id in let effect_info = get_fun_effect_info ctx.fun_context.fun_infos (FunId fun_id) (Some vloop_id) (Some rg_id) @@ -2229,7 +2236,7 @@ and translate_assertion (ectx : C.eval_ctx) (v : V.typed_value) let func = { id = FunOrOp (Fun (Pure Assert)); generics = empty_generic_args } in - let func_ty = mk_arrow (Literal Bool) mk_unit_ty in + let func_ty = mk_arrow (TLiteral TBool) mk_unit_ty in let func = { e = Qualif func; ty = func_ty } in let assertion = mk_apps func args in mk_let monadic (mk_dummy_pattern mk_unit_ty) assertion next_e @@ -2325,12 +2332,12 @@ 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.Scalar v) in + let pat = mk_typed_pattern_from_literal (PV.VScalar v) in { pat; branch } in let branches = List.map translate_branch branches in let otherwise = translate_expression otherwise ctx in - let pat_ty = Literal (Integer int_ty) in + let pat_ty = TLiteral (TInteger int_ty) in let otherwise_pat : typed_pattern = { value = PatDummy; ty = pat_ty } in let otherwise : match_branch = { pat = otherwise_pat; branch = otherwise } @@ -2433,7 +2440,7 @@ and translate_ExpandAdt_one_branch (sv : V.symbolic_value) (mk_simpl_tuple_pattern vars) (mk_opt_mplace_texpression scrutinee_mplace scrutinee) branch - | T.Assumed T.Box -> + | T.TAssumed T.TBox -> (* There should be exactly one variable *) let var = match vars with [ v ] -> v | _ -> raise (Failure "Unreachable") @@ -2445,7 +2452,7 @@ and translate_ExpandAdt_one_branch (sv : V.symbolic_value) (mk_typed_pattern_from_var var None) (mk_opt_mplace_texpression scrutinee_mplace scrutinee) branch - | T.Assumed (T.Array | T.Slice | T.Str) -> + | T.TAssumed (T.TArray | T.TSlice | T.TStr) -> (* We can't expand those values: we can access the fields only * through the functions provided by the API (note that we don't * know how to expand values like vectors or arrays, because they have a variable number @@ -2469,19 +2476,19 @@ and translate_intro_symbolic (ectx : C.eval_ctx) (p : S.mplace option) *) let v = match v with - | SingleValue v -> typed_value_to_texpression ctx ectx v - | Array values -> + | VaSingleValue v -> typed_value_to_texpression ctx ectx v + | VaArray values -> (* We use a struct update to encode the array aggregate, in order to preserve the structure and allow generating code of the shape `[x0, ...., xn]` *) let values = List.map (typed_value_to_texpression ctx ectx) values in let values = FieldId.mapi (fun fid v -> (fid, v)) values in let su : struct_update = - { struct_id = Assumed Array; init = None; updates = values } + { struct_id = TAssumed Array; init = None; updates = values } in { e = StructUpdate su; ty = var.ty } - | ConstGenericValue cg_id -> { e = CVar cg_id; ty = var.ty } - | TraitConstValue (trait_ref, generics, const_name) -> + | VaConstGenericValue cg_id -> { e = CVar cg_id; ty = var.ty } + | VaTraitConstValue (trait_ref, generics, const_name) -> let type_infos = ctx.type_context.type_infos in let trait_ref = translate_fwd_trait_ref type_infos trait_ref in let generics = translate_fwd_generic_args type_infos generics in @@ -2558,7 +2565,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.Regular ctx.fun_decl.A.def_id in + let fid = E.FRegular ctx.fun_decl.A.def_id in let effect_info = get_fun_effect_info ctx.fun_context.fun_infos (FunId fid) None ctx.bid in @@ -2661,7 +2668,7 @@ and translate_loop (loop : S.loop) (ctx : bs_ctx) : texpression = ^ T.RegionGroupId.Map.show (fun (rids, tys) -> "(" ^ T.RegionId.Set.show rids ^ ", " - ^ Print.list_to_string (rty_to_string ctx) tys + ^ Print.list_to_string (ty_to_string ctx) tys ^ ")") loop.rg_to_given_back_tys ^ "\n")); @@ -2925,8 +2932,8 @@ let translate_fun_decl (ctx : bs_ctx) (body : S.expression option) : fun_decl = | None -> None | Some body -> let effect_info = - get_fun_effect_info ctx.fun_context.fun_infos (FunId (Regular def_id)) - None bid + get_fun_effect_info ctx.fun_context.fun_infos + (FunId (FRegular def_id)) None bid in let body = translate_expression body ctx in (* Add a match over the fuel, if necessary *) @@ -2999,8 +3006,8 @@ let translate_fun_decl (ctx : bs_ctx) (body : S.expression option) : fun_decl = ^ "\n- back_state: " ^ String.concat ", " (List.map show_var back_state) ^ "\n- signature.inputs: " - ^ String.concat ", " (List.map (ty_to_string ctx) signature.inputs) - )); + ^ String.concat ", " + (List.map (pure_ty_to_string ctx) signature.inputs))); (* TODO: we need to normalize the types *) if !Config.type_check_pure_code then assert ( @@ -3070,7 +3077,7 @@ let translate_fun_signatures (decls_ctx : C.decls_ctx) (* The backward functions *) let back_sgs = List.map - (fun (rg : T.region_var_group) -> + (fun (rg : T.region_group) -> let tsg = translate_fun_sig decls_ctx fun_id sg input_names (Some rg.id) in diff --git a/compiler/SynthesizeSymbolic.ml b/compiler/SynthesizeSymbolic.ml index 9dd65c849..edd67749d 100644 --- a/compiler/SynthesizeSymbolic.ml +++ b/compiler/SynthesizeSymbolic.ml @@ -32,16 +32,16 @@ let synthesize_symbolic_expansion (sv : V.symbolic_value) (* Match on the symbolic value type to know which can of expansion happened *) let expansion = match sv.V.sv_ty with - | T.Literal PV.Bool -> ( + | T.TLiteral PV.TBool -> ( (* Boolean expansion: there should be two branches *) match ls with | [ - (Some (V.SeLiteral (PV.Bool true)), true_exp); - (Some (V.SeLiteral (PV.Bool false)), false_exp); + (Some (V.SeLiteral (PV.VBool true)), true_exp); + (Some (V.SeLiteral (PV.VBool false)), false_exp); ] -> ExpandBool (true_exp, false_exp) | _ -> raise (Failure "Ill-formed boolean expansion")) - | T.Literal (PV.Integer int_ty) -> + | T.TLiteral (PV.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 @@ -50,7 +50,7 @@ let synthesize_symbolic_expansion (sv : V.symbolic_value) let get_scalar (see : V.symbolic_expansion option) : V.scalar_value = match see with - | Some (V.SeLiteral (PV.Scalar cv)) -> + | Some (V.SeLiteral (PV.VScalar cv)) -> assert (cv.PV.int_ty = int_ty); cv | _ -> raise (Failure "Unreachable") @@ -64,7 +64,7 @@ let synthesize_symbolic_expansion (sv : V.symbolic_value) assert (otherwise_see = None); (* Return *) ExpandInt (int_ty, branches, otherwise) - | T.Adt (_, _) -> + | T.TAdt (_, _) -> (* Branching: it is necessarily an enumeration expansion *) let get_variant (see : V.symbolic_expansion option) : T.VariantId.id option * V.symbolic_value list = @@ -86,7 +86,7 @@ let synthesize_symbolic_expansion (sv : V.symbolic_value) | [ (Some see, exp) ] -> ExpandNoBranch (see, exp) | _ -> raise (Failure "Ill-formed borrow expansion")) | T.TypeVar _ - | T.Literal Char + | T.TLiteral TChar | Never | T.TraitType _ | T.Arrow _ | T.RawPtr _ -> raise (Failure "Ill-formed symbolic expansion") in @@ -99,7 +99,7 @@ let synthesize_symbolic_expansion_no_branching (sv : V.symbolic_value) 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.egeneric_args) + (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 = @@ -126,7 +126,7 @@ let synthesize_global_eval (gid : A.GlobalDeclId.id) (dest : V.symbolic_value) 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.egeneric_args) + (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 = @@ -171,7 +171,7 @@ 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.rty list) T.RegionGroupId.Map.t) + (T.RegionId.Set.t * T.ty list) T.RegionGroupId.Map.t) (end_expr : expression option) (loop_expr : expression option) : expression option = match (end_expr, loop_expr) with diff --git a/compiler/Translate.ml b/compiler/Translate.ml index a3d960233..9a6addee7 100644 --- a/compiler/Translate.ml +++ b/compiler/Translate.ml @@ -61,7 +61,7 @@ let translate_function_to_pure (trans_ctx : trans_ctx) (* Initialize the context *) let forward_sig = - RegularFunIdNotLoopMap.find (E.Regular def_id, None) fun_sigs + RegularFunIdNotLoopMap.find (E.FRegular def_id, None) fun_sigs in let sv_to_var = V.SymbolicValueId.Map.empty in let var_counter = Pure.VarId.generator_zero in @@ -188,7 +188,7 @@ let translate_function_to_pure (trans_ctx : trans_ctx) in (* Translate the backward functions *) - let translate_backward (rg : T.region_var_group) : Pure.fun_decl = + let translate_backward (rg : T.region_group) : Pure.fun_decl = (* For the backward inputs/outputs initialization: we use the fact that * there are no nested borrows for now, and so that the region groups * can't have parents *) @@ -200,7 +200,7 @@ let translate_function_to_pure (trans_ctx : trans_ctx) (* Initialize the context - note that the ret_ty is not really * useful as we don't translate a body *) let backward_sg = - RegularFunIdNotLoopMap.find (Regular def_id, Some back_id) fun_sigs + RegularFunIdNotLoopMap.find (FRegular def_id, Some back_id) fun_sigs in let ctx = { ctx with bid = Some back_id; sg = backward_sg.sg } in @@ -211,7 +211,7 @@ let translate_function_to_pure (trans_ctx : trans_ctx) variables required by the backward function. *) let backward_sg = - RegularFunIdNotLoopMap.find (Regular def_id, Some back_id) fun_sigs + RegularFunIdNotLoopMap.find (FRegular def_id, Some back_id) fun_sigs in (* We need to ignore the forward inputs, and the state input (if there is) *) let backward_inputs = @@ -298,7 +298,7 @@ let translate_crate_to_pure (crate : A.crate) : let assumed_sigs = List.map (fun (info : Assumed.assumed_fun_info) -> - ( E.Assumed info.fun_id, + ( E.FAssumed info.fun_id, List.map (fun _ -> None) info.fun_sig.inputs, info.fun_sig )) Assumed.assumed_fun_infos @@ -314,7 +314,7 @@ let translate_crate_to_pure (crate : A.crate) : (fun (v : A.var) -> v.name) (LlbcAstUtils.fun_body_get_input_vars body) in - (E.Regular fdef.def_id, input_names, fdef.signature)) + (E.FRegular fdef.def_id, input_names, fdef.signature)) (A.FunDeclId.Map.values crate.functions) in let sigs = List.append assumed_sigs local_sigs in diff --git a/compiler/TypesAnalysis.ml b/compiler/TypesAnalysis.ml index 38d350b11..6318c624f 100644 --- a/compiler/TypesAnalysis.ml +++ b/compiler/TypesAnalysis.ml @@ -77,9 +77,8 @@ let partial_type_info_to_type_decl_info (info : partial_type_info) : let partial_type_info_to_ty_info (info : partial_type_info) : ty_info = info.borrows_info -let analyze_full_ty (r_is_static : 'r -> bool) (updated : bool ref) - (infos : type_infos) (ty_info : partial_type_info) (ty : 'r ty) : - partial_type_info = +let analyze_full_ty (updated : bool ref) (infos : type_infos) + (ty_info : partial_type_info) (ty : ty) : partial_type_info = (* Small utility *) let check_update_bool (original : bool) (nv : bool) : bool = if nv && not original then ( @@ -87,6 +86,7 @@ let analyze_full_ty (r_is_static : 'r -> bool) (updated : bool ref) nv) else original in + let r_is_static (r : region) : bool = r = RStatic in (* Update a partial_type_info, while registering if we actually performed an update *) let update_ty_info (ty_info : partial_type_info) @@ -119,9 +119,9 @@ let analyze_full_ty (r_is_static : 'r -> bool) (updated : bool ref) (* The recursive function which explores the type *) let rec analyze (expl_info : expl_info) (ty_info : partial_type_info) - (ty : 'r ty) : partial_type_info = + (ty : ty) : partial_type_info = match ty with - | Literal _ | Never | TraitType _ -> ty_info + | TLiteral _ | Never | TraitType _ -> ty_info | TypeVar var_id -> ( (* Update the information for the proper parameter, if necessary *) match ty_info.param_infos with @@ -171,12 +171,12 @@ let analyze_full_ty (r_is_static : 'r -> bool) (updated : bool ref) | RawPtr (rty, _) -> (* TODO: not sure what to do here *) analyze expl_info ty_info rty - | Adt ((Tuple | Assumed (Box | Slice | Array | Str)), generics) -> + | TAdt ((Tuple | TAssumed (TBox | TSlice | TArray | TStr)), generics) -> (* Nothing to update: just explore the type parameters *) List.fold_left (fun ty_info ty -> analyze expl_info ty_info ty) ty_info generics.types - | Adt (AdtId adt_id, generics) -> + | TAdt (AdtId adt_id, generics) -> (* Lookup the information for this type definition *) let adt_info = TypeDeclId.Map.find adt_id infos in (* Update the type info with the information from the adt *) @@ -255,7 +255,7 @@ let analyze_type_decl (updated : bool ref) (infos : type_infos) if type_decl_is_opaque def then infos else (* Retrieve all the types of all the fields of all the variants *) - let fields_tys : sty list = + let fields_tys : ty list = match def.kind with | Struct fields -> List.map (fun f -> f.field_ty) fields | Enum variants -> @@ -266,13 +266,12 @@ let analyze_type_decl (updated : bool ref) (infos : type_infos) | Opaque -> raise (Failure "unreachable") in (* Explore the types and accumulate information *) - let r_is_static r = r = Static in let type_decl_info = TypeDeclId.Map.find def.def_id infos in let type_decl_info = type_decl_info_to_partial_type_info type_decl_info in let type_decl_info = List.fold_left (fun type_decl_info ty -> - analyze_full_ty r_is_static updated infos type_decl_info ty) + analyze_full_ty updated infos type_decl_info ty) type_decl_info fields_tys in let type_decl_info = partial_type_info_to_type_decl_info type_decl_info in @@ -324,12 +323,11 @@ let analyze_type_declarations (type_decls : type_decl TypeDeclId.Map.t) (** Analyze a type to check whether it contains borrows, etc., provided we have already analyzed the type definitions in the context. *) -let analyze_ty (infos : type_infos) (ty : 'r ty) : ty_info = +let analyze_ty (infos : type_infos) (ty : ty) : ty_info = (* We don't use [updated] but need to give it as parameter *) let updated = ref false in (* We don't need to compute whether the type contains 'static or not *) - let r_is_static _ = false in let ty_info = initialize_g_type_info None in - let ty_info = analyze_full_ty r_is_static updated infos ty_info ty in + let ty_info = analyze_full_ty updated infos ty_info ty in (* Convert the ty_info *) partial_type_info_to_ty_info ty_info diff --git a/compiler/TypesUtils.ml b/compiler/TypesUtils.ml index c7f0fbc37..54a120234 100644 --- a/compiler/TypesUtils.ml +++ b/compiler/TypesUtils.ml @@ -1,4 +1,5 @@ open Types +open Utils include Charon.TypesUtils module TA = TypesAnalysis @@ -8,7 +9,7 @@ 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 : 'r ty) : bool = +let ty_has_borrows (infos : TA.type_infos) (ty : ty) : bool = let info = TA.analyze_ty infos ty in info.TA.contains_borrow @@ -18,11 +19,91 @@ let ty_has_borrows (infos : TA.type_infos) (ty : 'r 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 : 'r ty) : bool = +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 (** Retuns true if the type contains a borrow under a mutable borrow *) -let ty_has_borrow_under_mut (infos : TA.type_infos) (ty : 'r ty) : bool = +let 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 + +(** Small helper *) +let raise_if_erased_ty_visitor = + object + inherit [_] iter_ty + method! visit_RErased _ = raise Found + end + +(** Return [true] if the type is a region type (i.e., it doesn't contain erased regions) *) +let ty_is_rty (ty : ty) : bool = + try + raise_if_erased_ty_visitor#visit_ty () ty; + true + with Found -> false + +(** Small helper *) +let raise_if_not_erased_ty_visitor = + object + inherit [_] iter_ty + method! visit_RStatic _ = raise Found + method! visit_RVar _ = raise Found + end + +(** Return [true] if the type is a region type (i.e., it doesn't contain erased regions) *) +let ty_is_ety (ty : ty) : bool = + try + raise_if_not_erased_ty_visitor#visit_ty () ty; + true + with Found -> false + +let generic_args_only_erased_regions (x : generic_args) : bool = + try + raise_if_not_erased_ty_visitor#visit_generic_args () x; + true + with Found -> false + +(** Small helper *) +let raise_if_region_ty_visitor = + object + inherit [_] iter_ty + method! visit_region _ _ = raise Found + end + +(** Return [true] if the type doesn't contain regions (including erased regions) *) +let ty_no_regions (ty : ty) : bool = + try + raise_if_region_ty_visitor#visit_ty () ty; + true + with Found -> false + +(** Return [true] if the trait ref doesn't contain regions (including erased regions) *) +let trait_ref_no_regions (x : trait_ref) : bool = + try + raise_if_region_ty_visitor#visit_trait_ref () x; + true + with Found -> false + +(** Return [true] if the trait instance id doesn't contain regions (including erased regions) *) +let trait_instance_id_no_regions (x : trait_instance_id) : bool = + try + raise_if_region_ty_visitor#visit_trait_instance_id () x; + true + with Found -> false + +(** Return [true] if the generic args don't contain regions (including erased regions) *) +let generic_args_no_regions (x : generic_args) : bool = + try + raise_if_region_ty_visitor#visit_generic_args () x; + true + with Found -> false + +(** Return [true] if the trait type constraint doesn't contain regions (including erased regions) *) +let trait_type_constraint_no_regions (x : trait_type_constraint) : bool = + try + let { trait_ref; generics; type_name = _; ty } = x in + raise_if_region_ty_visitor#visit_trait_ref () trait_ref; + raise_if_region_ty_visitor#visit_generic_args () generics; + raise_if_region_ty_visitor#visit_ty () ty; + true + with Found -> false diff --git a/compiler/Values.ml b/compiler/Values.ml index de27e7a91..8526ea662 100644 --- a/compiler/Values.ml +++ b/compiler/Values.ml @@ -58,55 +58,6 @@ type sv_kind = (** A symbolic value we introduce when evaluating a trait associated constant *) [@@deriving show, ord] -(** Ancestor for {!symbolic_value} iter visitor *) -class ['self] iter_symbolic_value_base = - object (_self : 'self) - inherit [_] VisitorsRuntime.iter - method visit_sv_kind : 'env -> sv_kind -> unit = fun _ _ -> () - method visit_rty : 'env -> rty -> unit = fun _ _ -> () - - method visit_symbolic_value_id : 'env -> symbolic_value_id -> unit = - fun _ _ -> () - end - -(** Ancestor for {!symbolic_value} map visitor for *) -class ['self] map_symbolic_value_base = - object (_self : 'self) - inherit [_] VisitorsRuntime.map - method visit_sv_kind : 'env -> sv_kind -> sv_kind = fun _ x -> x - method visit_rty : 'env -> rty -> rty = fun _ x -> x - - method visit_symbolic_value_id - : 'env -> symbolic_value_id -> symbolic_value_id = - fun _ x -> x - end - -(** A symbolic value *) -type symbolic_value = { - sv_kind : sv_kind; - sv_id : symbolic_value_id; - sv_ty : rty; -} -[@@deriving - show, - ord, - visitors - { - name = "iter_symbolic_value"; - variety = "iter"; - ancestors = [ "iter_symbolic_value_base" ]; - nude = true (* Don't inherit {!VisitorsRuntime.iter} *); - concrete = true; - }, - visitors - { - name = "map_symbolic_value"; - variety = "map"; - ancestors = [ "map_symbolic_value_base" ]; - nude = true (* Don't inherit {!VisitorsRuntime.iter} *); - concrete = true; - }] - type borrow_id = BorrowId.id [@@deriving show, ord] type borrow_id_set = BorrowId.Set.t [@@deriving show, ord] type loan_id = BorrowId.id [@@deriving show, ord] @@ -115,11 +66,13 @@ type loan_id_set = BorrowId.Set.t [@@deriving show, ord] (** Ancestor for {!typed_value} iter visitor *) class ['self] iter_typed_value_base = object (self : 'self) - inherit [_] iter_symbolic_value - method visit_literal : 'env -> literal -> unit = fun _ _ -> () - method visit_erased_region : 'env -> erased_region -> unit = fun _ _ -> () + inherit [_] iter_ty + method visit_sv_kind : 'env -> sv_kind -> unit = fun _ _ -> () + + method visit_symbolic_value_id : 'env -> symbolic_value_id -> unit = + fun _ _ -> () + method visit_variant_id : 'env -> variant_id -> unit = fun _ _ -> () - method visit_ety : 'env -> ety -> unit = fun _ _ -> () method visit_borrow_id : 'env -> borrow_id -> unit = fun _ _ -> () method visit_loan_id : 'env -> loan_id -> unit = fun _ _ -> () @@ -133,13 +86,13 @@ class ['self] iter_typed_value_base = (** Ancestor for {!typed_value} map visitor for *) class ['self] map_typed_value_base = object (self : 'self) - inherit [_] map_symbolic_value - method visit_literal : 'env -> literal -> literal = fun _ cv -> cv + inherit [_] map_ty + method visit_sv_kind : 'env -> sv_kind -> sv_kind = fun _ x -> x - method visit_erased_region : 'env -> erased_region -> erased_region = - fun _ r -> r + method visit_symbolic_value_id + : 'env -> symbolic_value_id -> symbolic_value_id = + fun _ x -> x - method visit_ety : 'env -> ety -> ety = fun _ ty -> ty method visit_variant_id : 'env -> variant_id -> variant_id = fun _ x -> x method visit_borrow_id : 'env -> borrow_id -> borrow_id = fun _ id -> id method visit_loan_id : 'env -> loan_id -> loan_id = fun _ id -> id @@ -151,10 +104,17 @@ class ['self] map_typed_value_base = fun env ids -> BorrowId.Set.map (self#visit_loan_id env) ids end -(** An untyped value, used in the environments *) -type value = - | Literal of literal (** Non-symbolic primitive value *) - | Adt of adt_value (** Enumerations and structures *) +(** A symbolic value *) +type symbolic_value = { + sv_kind : sv_kind; + sv_id : symbolic_value_id; + sv_ty : ty; (** This should be a type with regions *) +} + +(** An untyped value, used in the environments - TODO: prefix the names with "V" *) +and value = + | VLiteral of literal (** Non-symbolic primitive value *) + | VAdt of adt_value (** Enumerations and structures *) | Bottom (** No value (uninitialized or moved value) *) | Borrow of borrow_content (** A borrowed value *) | Loan of loan_content (** A loaned value *) @@ -215,25 +175,14 @@ and loan_content = | SharedLoan of loan_id_set * typed_value | MutLoan of loan_id -(** "Meta"-value: information we store for the synthesis. - - Note that we never automatically visit the meta-values with the - visitors: they really are meta information, and shouldn't be considered - as part of the environment during a symbolic execution. - - TODO: we may want to create wrappers, to prevent accidently mixing meta - values and regular values. - *) -and mvalue = typed_value - (** "Regular" typed value (we map variables to typed values) *) -and typed_value = { value : value; ty : ety } +and typed_value = { value : value; ty : ty } [@@deriving show, ord, visitors { - name = "iter_typed_value_visit_mvalue"; + name = "iter_typed_value"; variety = "iter"; ancestors = [ "iter_typed_value_base" ]; nude = true (* Don't inherit {!VisitorsRuntime.iter} *); @@ -241,13 +190,24 @@ and typed_value = { value : value; ty : ety } }, visitors { - name = "map_typed_value_visit_mvalue"; + name = "map_typed_value"; variety = "map"; ancestors = [ "map_typed_value_base" ]; nude = true (* Don't inherit {!VisitorsRuntime.iter} *); concrete = true; }] +(** "Meta"-value: information we store for the synthesis. + + Note that we never automatically visit the meta-values with the + visitors: they really are meta information, and shouldn't be considered + as part of the environment during a symbolic execution. + + TODO: we may want to create wrappers, to prevent accidently mixing meta + values and regular values. + *) +type mvalue = typed_value [@@deriving show, ord] + (** "Meta"-symbolic value. See the explanations for {!mvalue} @@ -257,28 +217,47 @@ and typed_value = { value : value; ty : ety } *) type msymbolic_value = symbolic_value [@@deriving show, ord] -class ['self] iter_typed_value = - object (_self : 'self) - inherit [_] iter_typed_value_visit_mvalue +type region_id = RegionId.id [@@deriving show, ord] +type region_id_set = RegionId.Set.t [@@deriving show, ord] +type abstraction_id = AbstractionId.id [@@deriving show, ord] +type abstraction_id_set = AbstractionId.Set.t [@@deriving show, ord] - (** We have to override the {!iter_typed_value_visit_mvalue.visit_mvalue} method, - to ignore meta-values *) - method! visit_mvalue : 'env -> mvalue -> unit = fun _ _ -> () +(** Ancestor for {!typed_avalue} iter visitor *) +class ['self] iter_typed_avalue_base = + object (self : 'self) + inherit [_] iter_typed_value + method visit_mvalue : 'env -> mvalue -> unit = fun _ _ -> () method visit_msymbolic_value : 'env -> msymbolic_value -> unit = fun _ _ -> () - end -class ['self] map_typed_value = - object (_self : 'self) - inherit [_] map_typed_value_visit_mvalue + method visit_region_id_set : 'env -> region_id_set -> unit = + fun env ids -> RegionId.Set.iter (self#visit_region_id env) ids + + method visit_abstraction_id : 'env -> abstraction_id -> unit = fun _ _ -> () - (** We have to override the {!iter_typed_value_visit_mvalue.visit_mvalue} method, - to ignore meta-values *) - method! visit_mvalue : 'env -> mvalue -> mvalue = fun _ x -> x + method visit_abstraction_id_set : 'env -> abstraction_id_set -> unit = + fun env ids -> AbstractionId.Set.iter (self#visit_abstraction_id env) ids + end + +(** Ancestor for {!typed_avalue} map visitor *) +class ['self] map_typed_avalue_base = + object (self : 'self) + inherit [_] map_typed_value + method visit_mvalue : 'env -> mvalue -> mvalue = fun _ x -> x method visit_msymbolic_value : 'env -> msymbolic_value -> msymbolic_value = fun _ m -> m + + method visit_region_id_set : 'env -> region_id_set -> region_id_set = + fun env ids -> RegionId.Set.map (self#visit_region_id env) ids + + method visit_abstraction_id : 'env -> abstraction_id -> abstraction_id = + fun _ x -> x + + method visit_abstraction_id_set + : 'env -> abstraction_id_set -> abstraction_id_set = + fun env ids -> AbstractionId.Set.map (self#visit_abstraction_id env) ids end (** When giving shared borrows to functions (i.e., inserting shared borrows inside @@ -297,62 +276,12 @@ class ['self] map_typed_value = *) type abstract_shared_borrow = | AsbBorrow of borrow_id - | AsbProjReborrows of symbolic_value * rty -[@@deriving - show, - ord, - visitors - { - name = "iter_abstract_shared_borrow"; - variety = "iter"; - ancestors = [ "iter_typed_value" ]; - nude = true (* Don't inherit {!VisitorsRuntime.iter} *); - concrete = true; - }, - visitors - { - name = "map_abstract_shared_borrow"; - variety = "map"; - ancestors = [ "map_typed_value" ]; - nude = true (* Don't inherit {!VisitorsRuntime.iter} *); - concrete = true; - }] + | AsbProjReborrows of symbolic_value * ty (** A set of abstract shared borrows *) -type abstract_shared_borrows = abstract_shared_borrow list -[@@deriving - show, - ord, - visitors - { - name = "iter_abstract_shared_borrows"; - variety = "iter"; - ancestors = [ "iter_abstract_shared_borrow" ]; - nude = true (* Don't inherit {!VisitorsRuntime.iter} *); - concrete = true; - }, - visitors - { - name = "map_abstract_shared_borrows"; - variety = "map"; - ancestors = [ "map_abstract_shared_borrow" ]; - nude = true (* Don't inherit {!VisitorsRuntime.iter} *); - concrete = true; - }] - -(** Ancestor for {!aproj} iter visitor *) -class ['self] iter_aproj_base = - object (_self : 'self) - inherit [_] iter_abstract_shared_borrows - end - -(** Ancestor for {!aproj} map visitor *) -class ['self] map_aproj_base = - object (_self : 'self) - inherit [_] map_abstract_shared_borrows - end +and abstract_shared_borrows = abstract_shared_borrow list -type aproj = +and aproj = | AProjLoans of symbolic_value * (msymbolic_value * aproj) list (** A projector of loans over a symbolic value. @@ -393,7 +322,7 @@ type aproj = anywhere in the context below a projector of borrows which intersects this projector of loans. *) - | AProjBorrows of symbolic_value * rty + | AProjBorrows of symbolic_value * ty (** Note that an AProjBorrows only operates on a value which is not below a shared loan: under a shared loan, we use {!abstract_shared_borrow}. @@ -414,82 +343,6 @@ type aproj = ending the borrow. *) | AIgnoredProjBorrows -[@@deriving - show, - ord, - visitors - { - name = "iter_aproj"; - variety = "iter"; - ancestors = [ "iter_aproj_base" ]; - nude = true (* Don't inherit {!VisitorsRuntime.iter} *); - concrete = true; - }, - visitors - { - name = "map_aproj"; - variety = "map"; - ancestors = [ "map_aproj_base" ]; - nude = true (* Don't inherit {!VisitorsRuntime.iter} *); - concrete = true; - }] - -type region = RegionVarId.id Types.region [@@deriving show, ord] -type region_var_id = RegionVarId.id [@@deriving show, ord] -type region_id = RegionId.id [@@deriving show, ord] -type region_id_set = RegionId.Set.t [@@deriving show, ord] -type abstraction_id = AbstractionId.id [@@deriving show, ord] -type abstraction_id_set = AbstractionId.Set.t [@@deriving show, ord] - -(** Ancestor for {!typed_avalue} iter visitor *) -class ['self] iter_typed_avalue_base = - object (self : 'self) - inherit [_] iter_aproj - method visit_region_var_id : 'env -> region_var_id -> unit = fun _ _ -> () - - method visit_region : 'env -> region -> unit = - fun env r -> - match r with - | Static -> () - | Var rid -> self#visit_region_var_id env rid - - method visit_region_id : 'env -> region_id -> unit = fun _ _ -> () - - method visit_region_id_set : 'env -> region_id_set -> unit = - fun env ids -> RegionId.Set.iter (self#visit_region_id env) ids - - method visit_abstraction_id : 'env -> abstraction_id -> unit = fun _ _ -> () - - method visit_abstraction_id_set : 'env -> abstraction_id_set -> unit = - fun env ids -> AbstractionId.Set.iter (self#visit_abstraction_id env) ids - end - -(** Ancestor for {!typed_avalue} map visitor *) -class ['self] map_typed_avalue_base = - object (self : 'self) - inherit [_] map_aproj - - method visit_region_var_id : 'env -> region_var_id -> region_var_id = - fun _ x -> x - - method visit_region : 'env -> region -> region = - fun env r -> - match r with - | Static -> Static - | Var rid -> Var (self#visit_region_var_id env rid) - - method visit_region_id : 'env -> region_id -> region_id = fun _ x -> x - - method visit_region_id_set : 'env -> region_id_set -> region_id_set = - fun env ids -> RegionId.Set.map (self#visit_region_id env) ids - - method visit_abstraction_id : 'env -> abstraction_id -> abstraction_id = - fun _ x -> x - - method visit_abstraction_id_set - : 'env -> abstraction_id_set -> abstraction_id_set = - fun env ids -> AbstractionId.Set.map (self#visit_abstraction_id env) ids - end (** Abstraction values are used inside of abstractions to properly model borrowing relations introduced by function calls. @@ -497,7 +350,7 @@ class ['self] map_typed_avalue_base = When calling a function, we lose information about the borrow graph: part of it is thus "abstracted" away. *) -type avalue = +and avalue = | AAdt of adt_avalue | ABottom (* TODO: remove once we change the way internal borrows are ended *) | ALoan of aloan_content @@ -875,7 +728,10 @@ and aborrow_content = To be more precise, shared aloans have the borrow type (i.e., a shared aloan has type [& (mut) T] instead of [T]). *) -and typed_avalue = { value : avalue; ty : rty } +and typed_avalue = { + value : avalue; + ty : ty; (** This should be a type with regions *) +} [@@deriving show, ord, diff --git a/compiler/ValuesUtils.ml b/compiler/ValuesUtils.ml index 527434c18..244850025 100644 --- a/compiler/ValuesUtils.ml +++ b/compiler/ValuesUtils.ml @@ -9,13 +9,27 @@ include PrimitiveValuesUtils exception FoundSymbolicValue of symbolic_value let mk_unit_value : typed_value = - { value = Adt { variant_id = None; field_values = [] }; ty = mk_unit_ty } + { value = VAdt { variant_id = None; field_values = [] }; ty = mk_unit_ty } -let mk_typed_value (ty : ety) (value : value) : typed_value = { value; ty } -let mk_typed_avalue (ty : rty) (value : avalue) : typed_avalue = { value; ty } -let mk_bottom (ty : ety) : typed_value = { value = Bottom; ty } -let mk_abottom (ty : rty) : typed_avalue = { value = ABottom; ty } -let mk_aignored (ty : rty) : typed_avalue = { value = AIgnored; ty } +let mk_typed_value (ty : ty) (value : value) : typed_value = + assert (ty_is_ety ty); + { value; ty } + +let mk_typed_avalue (ty : ty) (value : avalue) : typed_avalue = + assert (ty_is_rty ty); + { value; ty } + +let mk_bottom (ty : ty) : typed_value = + assert (ty_is_ety ty); + { value = Bottom; ty } + +let mk_abottom (ty : ty) : typed_avalue = + assert (ty_is_rty ty); + { value = ABottom; ty } + +let mk_aignored (ty : ty) : typed_avalue = + assert (ty_is_rty ty); + { value = AIgnored; ty } let value_as_symbolic (v : value) : symbolic_value = match v with Symbolic v -> v | _ -> raise (Failure "Unexpected") @@ -23,7 +37,7 @@ let value_as_symbolic (v : value) : symbolic_value = (** Box a value *) let mk_box_value (v : typed_value) : typed_value = let box_ty = mk_box_ty v.ty in - let box_v = Adt { variant_id = None; field_values = [ v ] } in + let box_v = VAdt { variant_id = None; field_values = [ v ] } in mk_typed_value box_ty box_v let is_bottom (v : value) : bool = match v with Bottom -> true | _ -> false @@ -46,7 +60,7 @@ let is_unit (v : typed_value) : bool = ty_is_unit v.ty && match v.value with - | Adt av -> av.variant_id = None && av.field_values = [] + | VAdt av -> av.variant_id = None && av.field_values = [] | _ -> false (** Check if a value contains a *concrete* borrow (i.e., a [Borrow] value -