diff options
43 files changed, 2155 insertions, 1435 deletions
diff --git a/compiler/AssociatedTypes.ml b/compiler/AssociatedTypes.ml index a4b0e921..5d5f53a4 100644 --- a/compiler/AssociatedTypes.ml +++ b/compiler/AssociatedTypes.ml @@ -83,7 +83,7 @@ let compute_norm_trait_types_from_preds (meta : Meta.meta option) let ctx_add_norm_trait_types_from_preds (meta : Meta.meta) (ctx : eval_ctx) (trait_type_constraints : trait_type_constraint list) : eval_ctx = let norm_trait_types = - compute_norm_trait_types_from_preds (Some meta) trait_type_constraints + compute_norm_trait_types_from_preds (Some meta) trait_type_constraints in { ctx with norm_trait_types } @@ -239,7 +239,9 @@ let rec norm_ctx_normalize_ty (ctx : norm_ctx) (ty : ty) : ty = match trait_ref.trait_id with | TraitRef { trait_id = TraitImpl impl_id; generics = ref_generics; _ } -> - cassert_opt_meta (ref_generics = empty_generic_args) ctx.meta "Higher order trait types are not supported yet"; + cassert_opt_meta + (ref_generics = empty_generic_args) + ctx.meta "Higher order trait types are not supported yet"; log#ldebug (lazy ("norm_ctx_normalize_ty: trait type: trait ref: " @@ -279,7 +281,9 @@ let rec norm_ctx_normalize_ty (ctx : norm_ctx) (ty : ty) : ty = ^ trait_ref_to_string ctx trait_ref ^ "\n- raw trait ref:\n" ^ show_trait_ref trait_ref)); (* We can't project *) - sanity_check_opt_meta (trait_instance_id_is_local_clause trait_ref.trait_id) ctx.meta ; + sanity_check_opt_meta + (trait_instance_id_is_local_clause trait_ref.trait_id) + ctx.meta; TTraitType (trait_ref, type_name) in let tr : trait_type_ref = { trait_ref; type_name } in @@ -347,7 +351,9 @@ and norm_ctx_normalize_trait_instance_id (ctx : norm_ctx) match impl with | None -> (* This is actually a local clause *) - sanity_check_opt_meta (trait_instance_id_is_local_clause inst_id) ctx.meta ; + sanity_check_opt_meta + (trait_instance_id_is_local_clause inst_id) + ctx.meta; (ParentClause (inst_id, decl_id, clause_id), None) | Some impl -> (* We figure out the parent clause by doing the following: @@ -378,7 +384,9 @@ and norm_ctx_normalize_trait_instance_id (ctx : norm_ctx) match impl with | None -> (* This is actually a local clause *) - sanity_check_opt_meta (trait_instance_id_is_local_clause inst_id) ctx.meta ; + sanity_check_opt_meta + (trait_instance_id_is_local_clause inst_id) + ctx.meta; (ItemClause (inst_id, decl_id, item_name, clause_id), None) | Some impl -> (* We figure out the item clause by doing the following: @@ -418,8 +426,12 @@ and norm_ctx_normalize_trait_instance_id (ctx : norm_ctx) | TraitRef trait_ref -> (* The trait instance id necessarily refers to a local sub-clause. We can't project over it and can only peel off the [TraitRef] wrapper *) - cassert_opt_meta (trait_instance_id_is_local_clause trait_ref.trait_id) ctx.meta "Trait instance id is not a local sub-clause"; - cassert_opt_meta (trait_ref.generics = empty_generic_args) ctx.meta "TODO: error message"; + cassert_opt_meta + (trait_instance_id_is_local_clause trait_ref.trait_id) + ctx.meta "Trait instance id is not a local sub-clause"; + cassert_opt_meta + (trait_ref.generics = empty_generic_args) + ctx.meta "TODO: error message"; (trait_ref.trait_id, None) | FnPointer ty -> let ty = norm_ctx_normalize_ty ctx ty in @@ -468,7 +480,9 @@ and norm_ctx_normalize_trait_ref (ctx : norm_ctx) (trait_ref : trait_ref) : (lazy ("norm_ctx_normalize_trait_ref: normalized to: " ^ trait_ref_to_string ctx trait_ref)); - cassert_opt_meta (generics = empty_generic_args) ctx.meta "TODO: error message"; + cassert_opt_meta + (generics = empty_generic_args) + ctx.meta "TODO: error message"; trait_ref (* Not sure this one is really necessary *) @@ -511,8 +525,8 @@ let ctx_normalize_trait_type_constraint (meta : Meta.meta) (ctx : eval_ctx) norm_ctx_normalize_trait_type_constraint (mk_norm_ctx meta ctx) ttc (** Same as [type_decl_get_instantiated_variants_fields_types] but normalizes the types *) -let type_decl_get_inst_norm_variants_fields_rtypes (meta : Meta.meta) (ctx : eval_ctx) - (def : type_decl) (generics : generic_args) : +let type_decl_get_inst_norm_variants_fields_rtypes (meta : Meta.meta) + (ctx : eval_ctx) (def : type_decl) (generics : generic_args) : (VariantId.id option * ty list) list = let res = Subst.type_decl_get_instantiated_variants_fields_types def generics @@ -523,16 +537,17 @@ let type_decl_get_inst_norm_variants_fields_rtypes (meta : Meta.meta) (ctx : eva res (** Same as [type_decl_get_instantiated_field_types] but normalizes the types *) -let type_decl_get_inst_norm_field_rtypes (meta : Meta.meta) (ctx : eval_ctx) (def : type_decl) - (opt_variant_id : VariantId.id option) (generics : generic_args) : ty list = +let type_decl_get_inst_norm_field_rtypes (meta : Meta.meta) (ctx : eval_ctx) + (def : type_decl) (opt_variant_id : VariantId.id option) + (generics : generic_args) : ty list = let types = Subst.type_decl_get_instantiated_field_types def opt_variant_id generics in List.map (ctx_normalize_ty meta ctx) types (** Same as [ctx_adt_value_get_instantiated_field_rtypes] but normalizes the types *) -let ctx_adt_value_get_inst_norm_field_rtypes (meta : Meta.meta) (ctx : eval_ctx) (adt : adt_value) - (id : type_id) (generics : generic_args) : ty list = +let ctx_adt_value_get_inst_norm_field_rtypes (meta : Meta.meta) (ctx : eval_ctx) + (adt : adt_value) (id : type_id) (generics : generic_args) : ty list = let types = Subst.ctx_adt_value_get_instantiated_field_types meta ctx adt id generics in @@ -540,8 +555,9 @@ let ctx_adt_value_get_inst_norm_field_rtypes (meta : Meta.meta) (ctx : eval_ctx) (** Same as [ctx_adt_value_get_instantiated_field_types] but normalizes the types and erases the regions. *) -let type_decl_get_inst_norm_field_etypes (meta : Meta.meta) (ctx : eval_ctx) (def : type_decl) - (opt_variant_id : VariantId.id option) (generics : generic_args) : ty list = +let type_decl_get_inst_norm_field_etypes (meta : Meta.meta) (ctx : eval_ctx) + (def : type_decl) (opt_variant_id : VariantId.id option) + (generics : generic_args) : ty list = let types = Subst.type_decl_get_instantiated_field_types def opt_variant_id generics in @@ -550,8 +566,9 @@ let type_decl_get_inst_norm_field_etypes (meta : Meta.meta) (ctx : eval_ctx) (de (** Same as [ctx_adt_get_instantiated_field_types] but normalizes the types and erases the regions. *) -let ctx_adt_get_inst_norm_field_etypes (meta : Meta.meta) (ctx : eval_ctx) (def_id : TypeDeclId.id) - (opt_variant_id : VariantId.id option) (generics : generic_args) : ty list = +let ctx_adt_get_inst_norm_field_etypes (meta : Meta.meta) (ctx : eval_ctx) + (def_id : TypeDeclId.id) (opt_variant_id : VariantId.id option) + (generics : generic_args) : ty list = let types = Subst.ctx_adt_get_instantiated_field_types ctx def_id opt_variant_id generics @@ -575,6 +592,8 @@ let ctx_subst_norm_signature (meta : Meta.meta) (ctx : eval_ctx) let inputs = List.map (ctx_normalize_ty meta ctx) inputs in let output = ctx_normalize_ty meta ctx output in let trait_type_constraints = - List.map (ctx_normalize_trait_type_constraint meta ctx) trait_type_constraints + List.map + (ctx_normalize_trait_type_constraint meta ctx) + trait_type_constraints in { regions_hierarchy; inputs; output; trait_type_constraints } diff --git a/compiler/Contexts.ml b/compiler/Contexts.ml index 51392edf..c2d6999a 100644 --- a/compiler/Contexts.ml +++ b/compiler/Contexts.ml @@ -286,7 +286,8 @@ let lookup_const_generic_var (ctx : eval_ctx) (vid : ConstGenericVarId.id) : ConstGenericVarId.nth ctx.const_generic_vars vid (** Lookup a variable in the current frame *) -let env_lookup_var (meta : Meta.meta) (env : env) (vid : VarId.id) : var_binder * typed_value = +let env_lookup_var (meta : Meta.meta) (env : env) (vid : VarId.id) : + var_binder * typed_value = (* We take care to stop at the end of current frame: different variables in different frames can have the same id! *) @@ -301,7 +302,8 @@ let env_lookup_var (meta : Meta.meta) (env : env) (vid : VarId.id) : var_binder in lookup env -let ctx_lookup_var_binder (meta : Meta.meta) (ctx : eval_ctx) (vid : VarId.id) : var_binder = +let ctx_lookup_var_binder (meta : Meta.meta) (ctx : eval_ctx) (vid : VarId.id) : + var_binder = fst (env_lookup_var meta ctx.env vid) let ctx_lookup_type_decl (ctx : eval_ctx) (tid : TypeDeclId.id) : type_decl = @@ -321,11 +323,13 @@ let ctx_lookup_trait_impl (ctx : eval_ctx) (id : TraitImplId.id) : trait_impl = TraitImplId.Map.find id ctx.trait_impls_ctx.trait_impls (** Retrieve a variable's value in the current frame *) -let env_lookup_var_value (meta : Meta.meta) (env : env) (vid : VarId.id) : typed_value = +let env_lookup_var_value (meta : Meta.meta) (env : env) (vid : VarId.id) : + typed_value = snd (env_lookup_var meta env vid) (** Retrieve a variable's value in an evaluation context *) -let ctx_lookup_var_value (meta : Meta.meta) (ctx : eval_ctx) (vid : VarId.id) : typed_value = +let ctx_lookup_var_value (meta : Meta.meta) (ctx : eval_ctx) (vid : VarId.id) : + typed_value = env_lookup_var_value meta ctx.env vid (** Retrieve a const generic value in an evaluation context *) @@ -338,7 +342,8 @@ let ctx_lookup_const_generic_value (ctx : eval_ctx) (vid : ConstGenericVarId.id) This is a helper function: it can break invariants and doesn't perform any check. *) -let env_update_var_value (meta : Meta.meta) (env : env) (vid : VarId.id) (nv : typed_value) : env = +let env_update_var_value (meta : Meta.meta) (env : env) (vid : VarId.id) + (nv : typed_value) : env = (* We take care to stop at the end of current frame: different variables in different frames can have the same id! *) @@ -361,8 +366,8 @@ let var_to_binder (var : var) : var_binder = This is a helper function: it can break invariants and doesn't perform any check. *) -let ctx_update_var_value (meta : Meta.meta) (ctx : eval_ctx) (vid : VarId.id) (nv : typed_value) : - eval_ctx = +let ctx_update_var_value (meta : Meta.meta) (ctx : eval_ctx) (vid : VarId.id) + (nv : typed_value) : eval_ctx = { ctx with env = env_update_var_value meta ctx.env vid nv } (** Push a variable in the context's environment. @@ -370,8 +375,11 @@ let ctx_update_var_value (meta : Meta.meta) (ctx : eval_ctx) (vid : VarId.id) (n Checks that the pushed variable and its value have the same type (this is important). *) -let ctx_push_var (meta : Meta.meta) (ctx : eval_ctx) (var : var) (v : typed_value) : eval_ctx = - cassert (TypesUtils.ty_is_ety var.var_ty && var.var_ty = v.ty) meta "The pushed variables and their values do not have the same type"; +let ctx_push_var (meta : Meta.meta) (ctx : eval_ctx) (var : var) + (v : typed_value) : eval_ctx = + cassert + (TypesUtils.ty_is_ety var.var_ty && var.var_ty = v.ty) + meta "The pushed variables and their values do not have the same type"; let bv = var_to_binder var in { ctx with env = EBinding (BVar bv, v) :: ctx.env } @@ -380,8 +388,8 @@ let ctx_push_var (meta : Meta.meta) (ctx : eval_ctx) (var : var) (v : typed_valu Checks that the pushed variables and their values have the same type (this is important). *) -let ctx_push_vars (meta : Meta.meta) (ctx : eval_ctx) (vars : (var * typed_value) list) : eval_ctx - = +let ctx_push_vars (meta : Meta.meta) (ctx : eval_ctx) + (vars : (var * typed_value) list) : eval_ctx = log#ldebug (lazy ("push_vars:\n" @@ -391,11 +399,14 @@ let ctx_push_vars (meta : Meta.meta) (ctx : eval_ctx) (vars : (var * typed_value (* We can unfortunately not use Print because it depends on Contexts... *) show_var var ^ " -> " ^ show_typed_value value) vars))); - cassert ( - List.for_all - (fun (var, (value : typed_value)) -> - TypesUtils.ty_is_ety var.var_ty && var.var_ty = value.ty) - vars) meta "The pushed variables and their values do not have the same type TODO: Error message"; + cassert + (List.for_all + (fun (var, (value : typed_value)) -> + TypesUtils.ty_is_ety var.var_ty && var.var_ty = value.ty) + vars) + meta + "The pushed variables and their values do not have the same type TODO: \ + Error message"; let vars = List.map (fun (var, value) -> EBinding (BVar (var_to_binder var), value)) @@ -431,7 +442,8 @@ let ctx_remove_dummy_var meta (ctx : eval_ctx) (vid : DummyVarId.id) : ({ ctx with env }, v) (** Lookup a dummy variable in a context's environment. *) -let ctx_lookup_dummy_var (meta : Meta.meta) (ctx : eval_ctx) (vid : DummyVarId.id) : typed_value = +let ctx_lookup_dummy_var (meta : Meta.meta) (ctx : eval_ctx) + (vid : DummyVarId.id) : typed_value = let rec lookup_var (env : env) : typed_value = match env with | [] -> craise meta "Could not lookup a dummy variable" @@ -450,12 +462,16 @@ let erase_regions (ty : ty) : ty = v#visit_ty () ty (** Push an uninitialized variable (which thus maps to {!constructor:Values.value.VBottom}) *) -let ctx_push_uninitialized_var (meta : Meta.meta) (ctx : eval_ctx) (var : var) : eval_ctx = +let ctx_push_uninitialized_var (meta : Meta.meta) (ctx : eval_ctx) (var : var) : + eval_ctx = ctx_push_var meta ctx var (mk_bottom meta (erase_regions var.var_ty)) (** Push a list of uninitialized variables (which thus map to {!constructor:Values.value.VBottom}) *) -let ctx_push_uninitialized_vars (meta : Meta.meta) (ctx : eval_ctx) (vars : var list) : eval_ctx = - let vars = List.map (fun v -> (v, mk_bottom meta (erase_regions v.var_ty))) vars in +let ctx_push_uninitialized_vars (meta : Meta.meta) (ctx : eval_ctx) + (vars : var list) : eval_ctx = + let vars = + List.map (fun v -> (v, mk_bottom meta (erase_regions v.var_ty))) vars + in ctx_push_vars meta ctx vars let env_find_abs (env : env) (pred : abs -> bool) : abs option = @@ -475,7 +491,8 @@ let env_lookup_abs_opt (env : env) (abs_id : AbstractionId.id) : abs option = this abstraction (for instance, remove the abs id from all the parent sets of all the other abstractions). *) -let env_remove_abs (meta : Meta.meta) (env : env) (abs_id : AbstractionId.id) : env * abs option = +let env_remove_abs (meta : Meta.meta) (env : env) (abs_id : AbstractionId.id) : + env * abs option = let rec remove (env : env) : env * abs option = match env with | [] -> craise meta "Unreachable" @@ -500,8 +517,8 @@ let env_remove_abs (meta : Meta.meta) (env : env) (abs_id : AbstractionId.id) : we also substitute the abstraction id wherever it is used (i.e., in the parent sets of the other abstractions). *) -let env_subst_abs (meta : Meta.meta) (env : env) (abs_id : AbstractionId.id) (nabs : abs) : - env * abs option = +let env_subst_abs (meta : Meta.meta) (env : env) (abs_id : AbstractionId.id) + (nabs : abs) : env * abs option = let rec update (env : env) : env * abs option = match env with | [] -> craise meta "Unreachable" @@ -536,19 +553,19 @@ let ctx_find_abs (ctx : eval_ctx) (p : abs -> bool) : abs option = env_find_abs ctx.env p (** See the comments for {!env_remove_abs} *) -let ctx_remove_abs (meta : Meta.meta) (ctx : eval_ctx) (abs_id : AbstractionId.id) : - eval_ctx * abs option = +let ctx_remove_abs (meta : Meta.meta) (ctx : eval_ctx) + (abs_id : AbstractionId.id) : eval_ctx * abs option = let env, abs = env_remove_abs meta ctx.env abs_id in ({ ctx with env }, abs) (** See the comments for {!env_subst_abs} *) -let ctx_subst_abs (meta : Meta.meta) (ctx : eval_ctx) (abs_id : AbstractionId.id) (nabs : abs) : - eval_ctx * abs option = +let ctx_subst_abs (meta : Meta.meta) (ctx : eval_ctx) + (abs_id : AbstractionId.id) (nabs : abs) : eval_ctx * abs option = let env, abs_opt = env_subst_abs meta ctx.env abs_id nabs in ({ ctx with env }, abs_opt) -let ctx_set_abs_can_end (meta : Meta.meta) (ctx : eval_ctx) (abs_id : AbstractionId.id) - (can_end : bool) : eval_ctx = +let ctx_set_abs_can_end (meta : Meta.meta) (ctx : eval_ctx) + (abs_id : AbstractionId.id) (can_end : bool) : eval_ctx = let abs = ctx_lookup_abs ctx abs_id in let abs = { abs with can_end } in fst (ctx_subst_abs meta ctx abs_id abs) diff --git a/compiler/Errors.ml b/compiler/Errors.ml index aff62022..3b34397a 100644 --- a/compiler/Errors.ml +++ b/compiler/Errors.ml @@ -1,10 +1,10 @@ -let meta_to_string (span : Meta.span ) = +let meta_to_string (span : Meta.span) = let file = match span.file with Virtual s | Local s -> s in let loc_to_string (l : Meta.loc) : string = string_of_int l.line ^ ":" ^ string_of_int l.col in - "Source: '" ^ file ^ "', lines " ^ loc_to_string span.beg_loc ^ "-" - ^ loc_to_string span.end_loc + "Source: '" ^ file ^ "', lines " ^ loc_to_string span.beg_loc ^ "-" + ^ loc_to_string span.end_loc let format_error_message (meta : Meta.meta) msg = msg ^ ":" ^ meta_to_string meta.span @@ -12,47 +12,44 @@ let format_error_message (meta : Meta.meta) msg = exception CFailure of string let error_list : (Meta.meta option * string) list ref = ref [] -let push_error (meta : Meta.meta option) (msg : string) = error_list := (meta, msg)::(!error_list) -let save_error ?(b : bool = true) (meta : Meta.meta option) (msg : string) = +let push_error (meta : Meta.meta option) (msg : string) = + error_list := (meta, msg) :: !error_list + +let save_error ?(b : bool = true) (meta : Meta.meta option) (msg : string) = push_error meta msg; - match meta with + match meta with | Some m -> - if !Config.fail_hard && b then - raise (Failure (format_error_message m msg)) - | None -> - if !Config.fail_hard && b then - raise (Failure msg) + if !Config.fail_hard && b then + raise (Failure (format_error_message m msg)) + | None -> if !Config.fail_hard && b then raise (Failure msg) let craise_opt_meta (meta : Meta.meta option) (msg : string) = - match meta with + match meta with | Some m -> - if !Config.fail_hard then - raise (Failure (format_error_message m msg)) - else - let () = push_error (Some m) msg in - raise (CFailure msg) - | None -> - if !Config.fail_hard then - raise (Failure msg) - else - let () = push_error None msg in - raise (CFailure msg) - -let craise (meta : Meta.meta) (msg : string) = - craise_opt_meta (Some meta) msg + if !Config.fail_hard then raise (Failure (format_error_message m msg)) + else + let () = push_error (Some m) msg in + raise (CFailure msg) + | None -> + if !Config.fail_hard then raise (Failure msg) + else + let () = push_error None msg in + raise (CFailure msg) + +let craise (meta : Meta.meta) (msg : string) = craise_opt_meta (Some meta) msg let cassert_opt_meta (b : bool) (meta : Meta.meta option) (msg : string) = - if b then - craise_opt_meta meta msg + if b then craise_opt_meta meta msg let cassert (b : bool) (meta : Meta.meta) (msg : string) = cassert_opt_meta b (Some meta) msg let sanity_check b meta = cassert b meta "Internal error, please file an issue" -let sanity_check_opt_meta b meta = cassert_opt_meta b meta "Internal error, please file an issue" -let internal_error meta = craise meta "Internal error, please report an issue" +let sanity_check_opt_meta b meta = + cassert_opt_meta b meta "Internal error, please file an issue" +let internal_error meta = craise meta "Internal error, please report an issue" let exec_raise = craise -let exec_assert = cassert
\ No newline at end of file +let exec_assert = cassert diff --git a/compiler/Extract.ml b/compiler/Extract.ml index 43acba94..72cd91e5 100644 --- a/compiler/Extract.ml +++ b/compiler/Extract.ml @@ -128,8 +128,12 @@ let extract_adt_g_value (meta : Meta.meta) | TAdt (TTuple, generics) -> (* Tuple *) (* For now, we only support fully applied tuple constructors *) - cassert (List.length generics.types = List.length field_values) meta "Only fully applied tuple constructors are currently supported"; - cassert (generics.const_generics = [] && generics.trait_refs = []) meta "Only fully applied tuple constructors are currently supported"; + cassert + (List.length generics.types = List.length field_values) + meta "Only fully applied tuple constructors are currently supported"; + cassert + (generics.const_generics = [] && generics.trait_refs = []) + meta "Only fully applied tuple constructors are currently supported"; extract_as_tuple () | TAdt (adt_id, _) -> (* "Regular" ADT *) @@ -186,8 +190,8 @@ let extract_adt_g_value (meta : Meta.meta) | _ -> craise meta "Inconsistent typed value" (* Extract globals in the same way as variables *) -let extract_global (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) (inside : bool) - (id : A.GlobalDeclId.id) (generics : generic_args) : unit = +let extract_global (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) + (inside : bool) (id : A.GlobalDeclId.id) (generics : generic_args) : unit = let use_brackets = inside && generics <> empty_generic_args in F.pp_open_hvbox fmt ctx.indent_incr; if use_brackets then F.pp_print_string fmt "("; @@ -232,9 +236,9 @@ let fun_builtin_filter_types (id : FunDeclId.id) (types : 'a list) As a pattern can introduce new variables, we return an extraction context updated with new bindings. *) -let rec extract_typed_pattern (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) - (is_let : bool) (inside : bool) ?(with_type = false) (v : typed_pattern) : - extraction_ctx = +let rec extract_typed_pattern (meta : Meta.meta) (ctx : extraction_ctx) + (fmt : F.formatter) (is_let : bool) (inside : bool) ?(with_type = false) + (v : typed_pattern) : extraction_ctx = if with_type then F.pp_print_string fmt "("; let inside = inside && not with_type in let ctx = @@ -254,8 +258,8 @@ let rec extract_typed_pattern (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F let extract_value ctx inside v = extract_typed_pattern meta ctx fmt is_let inside v in - extract_adt_g_value meta extract_value fmt ctx is_let inside av.variant_id - av.field_values v.ty + extract_adt_g_value meta extract_value fmt ctx is_let inside + av.variant_id av.field_values v.ty in if with_type then ( F.pp_print_space fmt (); @@ -267,8 +271,8 @@ let rec extract_typed_pattern (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F (** Return true if we need to wrap a succession of let-bindings in a [do ...] block (because some of them are monadic) *) -let lets_require_wrap_in_do (meta : Meta.meta) (lets : (bool * typed_pattern * texpression) list) : - bool = +let lets_require_wrap_in_do (meta : Meta.meta) + (lets : (bool * typed_pattern * texpression) list) : bool = match !backend with | Lean -> (* For Lean, we wrap in a block iff at least one of the let-bindings is monadic *) @@ -276,7 +280,8 @@ let lets_require_wrap_in_do (meta : Meta.meta) (lets : (bool * typed_pattern * t | HOL4 -> (* HOL4 is similar to HOL4, but we add a sanity check *) let wrap_in_do = List.exists (fun (m, _, _) -> m) lets in - if wrap_in_do then sanity_check (List.for_all (fun (m, _, _) -> m) lets) meta; + if wrap_in_do then + sanity_check (List.for_all (fun (m, _, _) -> m) lets) meta; wrap_in_do | FStar | Coq -> false @@ -290,8 +295,8 @@ let lets_require_wrap_in_do (meta : Meta.meta) (lets : (bool * typed_pattern * t - application argument: [f (exp)] - match/if scrutinee: [if exp then _ else _]/[match exp | _ -> _] *) -let rec extract_texpression (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) - (inside : bool) (e : texpression) : unit = +let rec extract_texpression (meta : Meta.meta) (ctx : extraction_ctx) + (fmt : F.formatter) (inside : bool) (e : texpression) : unit = match e.e with | Var var_id -> let var_name = ctx_get_var meta var_id ctx in @@ -320,8 +325,8 @@ let rec extract_texpression (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.f (* Extract an application *or* a top-level qualif (function extraction has * to handle top-level qualifiers, so it seemed more natural to merge the * two cases) *) -and extract_App (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) (inside : bool) - (app : texpression) (args : texpression list) : unit = +and extract_App (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) + (inside : bool) (app : texpression) (args : texpression list) : unit = (* We don't do the same thing if the app is a top-level identifier (function, * ADT constructor...) or a "regular" expression *) match app.e with @@ -336,7 +341,8 @@ and extract_App (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) (i | AdtCons adt_cons_id -> extract_adt_cons meta ctx fmt inside adt_cons_id qualif.generics args | Proj proj -> - extract_field_projector meta ctx fmt inside app proj qualif.generics args + extract_field_projector meta ctx fmt inside app proj qualif.generics + args | TraitConst (trait_ref, const_name) -> extract_trait_ref meta ctx fmt TypeDeclId.Set.empty true trait_ref; let name = @@ -368,9 +374,9 @@ and extract_App (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) (i if inside then F.pp_print_string fmt ")" (** Subcase of the app case: function call *) -and extract_function_call (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) - (inside : bool) (fid : fun_or_op_id) (generics : generic_args) - (args : texpression list) : unit = +and extract_function_call (meta : Meta.meta) (ctx : extraction_ctx) + (fmt : F.formatter) (inside : bool) (fid : fun_or_op_id) + (generics : generic_args) (args : texpression list) : unit = match (fid, args) with | Unop unop, [ arg ] -> (* A unop can have *at most* one argument (the result can't be a function!). @@ -448,8 +454,9 @@ and extract_function_call (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.for if not method_id.is_provided then ( (* Required method *) - sanity_check (lp_id = None) trait_decl.meta ; - extract_trait_ref trait_decl.meta ctx fmt TypeDeclId.Set.empty true trait_ref; + sanity_check (lp_id = None) trait_decl.meta; + extract_trait_ref trait_decl.meta ctx fmt TypeDeclId.Set.empty true + trait_ref; let fun_name = ctx_get_trait_method meta trait_ref.trait_decl_ref.trait_decl_id method_name ctx @@ -471,7 +478,8 @@ and extract_function_call (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.for Print the trait ref (to instantate the self clause) *) F.pp_print_space fmt (); - extract_trait_ref trait_decl.meta ctx fmt TypeDeclId.Set.empty true trait_ref + extract_trait_ref trait_decl.meta ctx fmt TypeDeclId.Set.empty true + trait_ref | _ -> let fun_name = ctx_get_function meta fun_id ctx in F.pp_print_string fmt fun_name); @@ -498,11 +506,11 @@ and extract_function_call (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.for extract_generic_args meta ctx fmt TypeDeclId.Set.empty { generics with types }; (* if !Config.fail_hard then craise meta err - else *) + else *) save_error (Some meta) err; F.pp_print_string fmt - "(\"ERROR: ill-formed builtin: invalid number of filtering \ - arguments\")"); + "(\"ERROR: ill-formed builtin: invalid number of filtering \ + arguments\")"); (* Print the arguments *) List.iter (fun ve -> @@ -514,18 +522,17 @@ and extract_function_call (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.for (* Return *) if inside then F.pp_print_string fmt ")" | (Unop _ | Binop _), _ -> - craise - meta - ("Unreachable:\n" ^ "Function: " ^ show_fun_or_op_id fid - ^ ",\nNumber of arguments: " - ^ string_of_int (List.length args) - ^ ",\nArguments: " - ^ String.concat " " (List.map show_texpression args)) + craise meta + ("Unreachable:\n" ^ "Function: " ^ show_fun_or_op_id fid + ^ ",\nNumber of arguments: " + ^ string_of_int (List.length args) + ^ ",\nArguments: " + ^ String.concat " " (List.map show_texpression args)) (** Subcase of the app case: ADT constructor *) -and extract_adt_cons (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) (inside : bool) - (adt_cons : adt_cons_id) (generics : generic_args) (args : texpression list) - : unit = +and extract_adt_cons (meta : Meta.meta) (ctx : extraction_ctx) + (fmt : F.formatter) (inside : bool) (adt_cons : adt_cons_id) + (generics : generic_args) (args : texpression list) : unit = let e_ty = TAdt (adt_cons.adt_id, generics) in let is_single_pat = false in let _ = @@ -538,9 +545,10 @@ and extract_adt_cons (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatte () (** Subcase of the app case: ADT field projector. *) -and extract_field_projector (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) - (inside : bool) (original_app : texpression) (proj : projection) - (_generics : generic_args) (args : texpression list) : unit = +and extract_field_projector (meta : Meta.meta) (ctx : extraction_ctx) + (fmt : F.formatter) (inside : bool) (original_app : texpression) + (proj : projection) (_generics : generic_args) (args : texpression list) : + unit = (* We isolate the first argument (if there is), in order to pretty print the * projection ([x.field] instead of [MkAdt?.field x] *) match args with @@ -638,14 +646,14 @@ and extract_field_projector (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.f (* No argument: shouldn't happen *) craise meta "Unreachable" -and extract_Lambda (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) (inside : bool) - (xl : typed_pattern list) (e : texpression) : unit = +and extract_Lambda (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) + (inside : bool) (xl : typed_pattern list) (e : texpression) : unit = (* Open a box for the abs expression *) F.pp_open_hovbox fmt ctx.indent_incr; (* Open parentheses *) if inside then F.pp_print_string fmt "("; (* Print the lambda - note that there should always be at least one variable *) - sanity_check (xl <> []) meta ; + sanity_check (xl <> []) meta; F.pp_print_string fmt "fun"; let with_type = !backend = Coq in let ctx = @@ -666,8 +674,8 @@ and extract_Lambda (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) (* Close the box for the abs expression *) F.pp_close_box fmt () -and extract_lets (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) (inside : bool) - (e : texpression) : unit = +and extract_lets (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) + (inside : bool) (e : texpression) : unit = (* Destruct the lets. Note that in the case of HOL4, we stop destructing the lets if at some point @@ -804,8 +812,8 @@ and extract_lets (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) ( (* Close the box for the whole expression *) F.pp_close_box fmt () -and extract_Switch (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) (_inside : bool) - (scrut : texpression) (body : switch_body) : unit = +and extract_Switch (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) + (_inside : bool) (scrut : texpression) (body : switch_body) : unit = (* Remark: we don't use the [inside] parameter because we extract matches in a conservative manner: we always make sure they are parenthesized/delimited with keywords such as [end] *) @@ -823,7 +831,9 @@ and extract_Switch (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) F.pp_print_string fmt "if"; if !backend = Lean && ctx.use_dep_ite then F.pp_print_string fmt " h:"; F.pp_print_space fmt (); - let scrut_inside = PureUtils.texpression_requires_parentheses meta scrut in + let scrut_inside = + PureUtils.texpression_requires_parentheses meta scrut + in extract_texpression meta ctx fmt scrut_inside scrut; (* Close the box for the [if e] *) F.pp_close_box fmt (); @@ -837,7 +847,9 @@ and extract_Switch (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) F.pp_open_hovbox fmt 0; let then_or_else = if is_then then "then" else "else" in F.pp_print_string fmt then_or_else; - let parenth = PureUtils.texpression_requires_parentheses meta e_branch in + let parenth = + PureUtils.texpression_requires_parentheses meta e_branch + in (* Open the parenthesized expression *) let print_space_after_parenth = if parenth then ( @@ -889,7 +901,9 @@ and extract_Switch (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) in F.pp_print_string fmt match_begin; F.pp_print_space fmt (); - let scrut_inside = PureUtils.texpression_requires_parentheses meta scrut in + let scrut_inside = + PureUtils.texpression_requires_parentheses meta scrut + in extract_texpression meta ctx fmt scrut_inside scrut; F.pp_print_space fmt (); let match_scrut_end = @@ -940,11 +954,12 @@ and extract_Switch (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) (* Close the box for the whole expression *) F.pp_close_box fmt () -and extract_StructUpdate (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) - (inside : bool) (e_ty : ty) (supd : struct_update) : unit = +and extract_StructUpdate (meta : Meta.meta) (ctx : extraction_ctx) + (fmt : F.formatter) (inside : bool) (e_ty : ty) (supd : struct_update) : + unit = (* We can't update a subset of the fields in Coq (i.e., we can do [{| x:= 3; y := 4 |}], but there is no syntax for [{| s with x := 3 |}]) *) - sanity_check (!backend <> Coq || supd.init = None) meta ; + sanity_check (!backend <> Coq || supd.init = None) meta; (* In the case of HOL4, records with no fields are not supported and are thus extracted to unit. We need to check that by looking up the definition *) let extract_as_unit = @@ -1133,8 +1148,8 @@ let extract_fun_parameters (space : bool ref) (ctx : extraction_ctx) (* Open a box for the generics *) F.pp_open_hovbox fmt 0; (let space = Some space in - extract_generic_params def.meta ctx fmt TypeDeclId.Set.empty ~space ~trait_decl - def.signature.generics type_params cg_params trait_clauses); + extract_generic_params def.meta ctx fmt TypeDeclId.Set.empty ~space + ~trait_decl def.signature.generics type_params cg_params trait_clauses); (* Close the box for the generics *) F.pp_close_box fmt (); (* The input parameters - note that doing this adds bindings to the context *) @@ -1187,8 +1202,8 @@ let assert_backend_supports_decreases_clauses (meta : Meta.meta) = match !backend with | FStar | Lean -> () | _ -> - craise - meta "Decreases clauses are only supported for the Lean and F* backends" + craise meta + "Decreases clauses are only supported for the Lean and F* backends" (** Extract a decreases clause function template body. @@ -1208,10 +1223,14 @@ let assert_backend_supports_decreases_clauses (meta : Meta.meta) = *) let extract_template_fstar_decreases_clause (ctx : extraction_ctx) (fmt : F.formatter) (def : fun_decl) : unit = - cassert (!backend = FStar) def.meta "The generation of template decrease clauses is only supported for the F* backend"; + cassert (!backend = FStar) def.meta + "The generation of template decrease clauses is only supported for the F* \ + backend"; (* Retrieve the function name *) - let def_name = ctx_get_termination_measure def.meta def.def_id def.loop_id ctx in + let def_name = + ctx_get_termination_measure def.meta def.def_id def.loop_id ctx + in (* Add a break before *) F.pp_print_break fmt 0 0; (* Print a comment to link the extracted type to its original rust definition *) @@ -1273,12 +1292,16 @@ let extract_template_fstar_decreases_clause (ctx : extraction_ctx) *) let extract_template_lean_termination_and_decreasing (ctx : extraction_ctx) (fmt : F.formatter) (def : fun_decl) : unit = - cassert (!backend = Lean) def.meta "The generation of template termination and decreasing clauses is only supported for the Lean backend" ; + cassert (!backend = Lean) def.meta + "The generation of template termination and decreasing clauses is only \ + supported for the Lean backend"; (* * Extract a template for the termination measure *) (* Retrieve the function name *) - let def_name = ctx_get_termination_measure def.meta def.def_id def.loop_id ctx in + let def_name = + ctx_get_termination_measure def.meta def.def_id def.loop_id ctx + in let def_body = Option.get def.body in (* Add a break before *) F.pp_print_break fmt 0 0; @@ -1396,7 +1419,7 @@ let extract_fun_comment (ctx : extraction_ctx) (fmt : F.formatter) *) let extract_fun_decl_gen (ctx : extraction_ctx) (fmt : F.formatter) (kind : decl_kind) (has_decreases_clause : bool) (def : fun_decl) : unit = - sanity_check (not def.is_global_decl_body) def.meta ; + sanity_check (not def.is_global_decl_body) def.meta; (* Retrieve the function name *) let def_name = ctx_get_local_function def.meta def.def_id def.loop_id ctx in (* Add a break before *) @@ -1489,7 +1512,9 @@ let extract_fun_decl_gen (ctx : extraction_ctx) (fmt : F.formatter) (* Open a box for the decreases term *) F.pp_open_hovbox fmt ctx.indent_incr; (* The name of the decrease clause *) - let decr_name = ctx_get_termination_measure def.meta def.def_id def.loop_id ctx in + let decr_name = + ctx_get_termination_measure def.meta def.def_id def.loop_id ctx + in F.pp_print_string fmt decr_name; (* Print the generic parameters - TODO: we do this many times, we should have a helper to factor it out *) @@ -1545,7 +1570,9 @@ let extract_fun_decl_gen (ctx : extraction_ctx) (fmt : F.formatter) (* Open a box for the body *) F.pp_open_hvbox fmt 0; (* Extract the body *) - let _ = extract_texpression def.meta ctx_body fmt false (Option.get def.body).body in + let _ = + extract_texpression def.meta ctx_body fmt false (Option.get def.body).body + in (* Close the box for the body *) F.pp_close_box fmt ()); (* Close the inner box for the definition *) @@ -1604,7 +1631,9 @@ let extract_fun_decl_gen (ctx : extraction_ctx) (fmt : F.formatter) F.pp_print_break fmt 0 0; (* Open a box for the [decreasing by ...] *) F.pp_open_hvbox fmt ctx.indent_incr; - let decreases_name = ctx_get_decreases_proof def.meta def.def_id def.loop_id ctx in + let decreases_name = + ctx_get_decreases_proof def.meta def.def_id def.loop_id ctx + in F.pp_print_string fmt "decreasing_by"; F.pp_print_space fmt (); F.pp_open_hvbox fmt ctx.indent_incr; @@ -1643,7 +1672,10 @@ let extract_fun_decl_hol4_opaque (ctx : extraction_ctx) (fmt : F.formatter) (def : fun_decl) : unit = (* Retrieve the definition name *) let def_name = ctx_get_local_function def.meta def.def_id def.loop_id ctx in - cassert (def.signature.generics.const_generics = []) def.meta "Constant generics are not supported yet when generating code for HOL4"; + cassert + (def.signature.generics.const_generics = []) + def.meta + "Constant generics are not supported yet when generating code for HOL4"; (* Add the type/const gen parameters - note that we need those bindings only for the generation of the type (they are not top-level) *) let ctx, _, _, _ = @@ -1689,7 +1721,7 @@ let extract_fun_decl_hol4_opaque (ctx : extraction_ctx) (fmt : F.formatter) *) let extract_fun_decl (ctx : extraction_ctx) (fmt : F.formatter) (kind : decl_kind) (has_decreases_clause : bool) (def : fun_decl) : unit = - sanity_check (not def.is_global_decl_body) def.meta ; + sanity_check (not def.is_global_decl_body) def.meta; (* We treat HOL4 opaque functions in a specific manner *) if !backend = HOL4 && Option.is_none def.body then extract_fun_decl_hol4_opaque ctx fmt def @@ -1702,10 +1734,10 @@ let extract_fun_decl (ctx : extraction_ctx) (fmt : F.formatter) extracted to two declarations, and we can actually factor out the generation of those declarations. See {!extract_global_decl} for more explanations. *) -let extract_global_decl_body_gen (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) - (kind : decl_kind) (name : string) (generics : generic_params) - (type_params : string list) (cg_params : string list) - (trait_clauses : string list) (ty : ty) +let extract_global_decl_body_gen (meta : Meta.meta) (ctx : extraction_ctx) + (fmt : F.formatter) (kind : decl_kind) (name : string) + (generics : generic_params) (type_params : string list) + (cg_params : string list) (trait_clauses : string list) (ty : ty) (extract_body : (F.formatter -> unit) Option.t) : unit = let is_opaque = Option.is_none extract_body in @@ -1794,8 +1826,9 @@ let extract_global_decl_body_gen (meta : Meta.meta) (ctx : extraction_ctx) (fmt Remark (SH): having to treat this specific case separately is very annoying, but I could not find a better way. *) -let extract_global_decl_hol4_opaque (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) - (name : string) (generics : generic_params) (ty : ty) : unit = +let extract_global_decl_hol4_opaque (meta : Meta.meta) (ctx : extraction_ctx) + (fmt : F.formatter) (name : string) (generics : generic_params) (ty : ty) : + unit = (* TODO: non-empty generics *) assert (generics = empty_generic_params); (* Open the definition boxe (depth=0) *) @@ -1838,7 +1871,6 @@ let extract_global_decl_hol4_opaque (meta : Meta.meta) (ctx : extraction_ctx) (f *) let extract_global_decl (ctx : extraction_ctx) (fmt : F.formatter) (global : global_decl) (body : fun_decl) (interface : bool) : unit = - let meta = body.meta in cassert body.is_global_decl_body body.meta "TODO: Error message"; cassert (body.signature.inputs = []) body.meta "TODO: Error message"; @@ -1857,7 +1889,9 @@ let extract_global_decl (ctx : extraction_ctx) (fmt : F.formatter) let decl_name = ctx_get_global meta global.def_id ctx in let body_name = - ctx_get_function meta (FromLlbc (Pure.FunId (FRegular global.body_id), None)) ctx + ctx_get_function meta + (FromLlbc (Pure.FunId (FRegular global.body_id), None)) + ctx in let decl_ty, body_ty = let ty = body.signature.output in @@ -1867,8 +1901,8 @@ let extract_global_decl (ctx : extraction_ctx) (fmt : F.formatter) in (* Add the type parameters *) let ctx, type_params, cg_params, trait_clauses = - ctx_add_generic_params meta global.llbc_name global.llbc_generics global.generics - ctx + ctx_add_generic_params meta global.llbc_name global.llbc_generics + global.generics ctx in match body.body with | None -> @@ -1957,7 +1991,9 @@ let extract_trait_decl_register_parent_clause_names (ctx : extraction_ctx) (* Register the names *) List.fold_left (fun ctx (cid, cname) -> - ctx_add trait_decl.meta (TraitParentClauseId (trait_decl.def_id, cid)) cname ctx) + ctx_add trait_decl.meta + (TraitParentClauseId (trait_decl.def_id, cid)) + cname ctx) ctx clause_names (** Similar to {!extract_trait_decl_register_names} *) @@ -1990,7 +2026,9 @@ let extract_trait_decl_register_constant_names (ctx : extraction_ctx) (* Register the names *) List.fold_left (fun ctx (item_name, name) -> - ctx_add trait_decl.meta (TraitItemId (trait_decl.def_id, item_name)) name ctx) + ctx_add trait_decl.meta + (TraitItemId (trait_decl.def_id, item_name)) + name ctx) ctx constant_names (** Similar to {!extract_trait_decl_register_names} *) @@ -2049,11 +2087,13 @@ let extract_trait_decl_type_names (ctx : extraction_ctx) List.fold_left (fun ctx (item_name, (type_name, clauses)) -> let ctx = - ctx_add trait_decl.meta (TraitItemId (trait_decl.def_id, item_name)) type_name ctx + ctx_add trait_decl.meta + (TraitItemId (trait_decl.def_id, item_name)) + type_name ctx in List.fold_left (fun ctx (clause_id, clause_name) -> - ctx_add trait_decl.meta + ctx_add trait_decl.meta (TraitItemClauseId (trait_decl.def_id, item_name, clause_id)) clause_name ctx) ctx clauses) @@ -2105,7 +2145,9 @@ let extract_trait_decl_method_names (ctx : extraction_ctx) (* Register the names *) List.fold_left (fun ctx (item_name, fun_name) -> - ctx_add trait_decl.meta (TraitMethodId (trait_decl.def_id, item_name)) fun_name ctx) + ctx_add trait_decl.meta + (TraitMethodId (trait_decl.def_id, item_name)) + fun_name ctx) ctx method_names (** Similar to {!extract_type_decl_register_names} *) @@ -2125,8 +2167,11 @@ let extract_trait_decl_register_names (ctx : extraction_ctx) ctx_compute_trait_decl_constructor ctx trait_decl ) | Some info -> (info.extract_name, info.constructor) in - let ctx = ctx_add trait_decl.meta (TraitDeclId trait_decl.def_id) trait_name ctx in - ctx_add trait_decl.meta (TraitDeclConstructorId trait_decl.def_id) trait_constructor ctx + let ctx = + ctx_add trait_decl.meta (TraitDeclId trait_decl.def_id) trait_name ctx + in + ctx_add trait_decl.meta (TraitDeclConstructorId trait_decl.def_id) + trait_constructor ctx in (* Parent clauses *) let ctx = @@ -2180,7 +2225,9 @@ let extract_trait_impl_register_names (ctx : extraction_ctx) in (* For now we do not support overriding provided methods *) - cassert (trait_impl.provided_methods = []) trait_impl.meta "Overriding provided methods is not supported yet"; + cassert + (trait_impl.provided_methods = []) + trait_impl.meta "Overriding provided methods is not supported yet"; (* Everything is taken care of by {!extract_trait_decl_register_names} *but* the name of the implementation itself *) (* Compute the name *) @@ -2254,7 +2301,8 @@ let extract_trait_decl_method_items (ctx : extraction_ctx) (fmt : F.formatter) - we only generate trait clauses for the clauses we find in the pure generics *) let ctx, type_params, cg_params, trait_clauses = - ctx_add_generic_params decl.meta f.llbc_name f.signature.llbc_generics generics ctx + ctx_add_generic_params decl.meta f.llbc_name f.signature.llbc_generics + generics ctx in let backend_uses_forall = match !backend with Coq | Lean -> true | FStar | HOL4 -> false @@ -2321,10 +2369,11 @@ let extract_trait_decl (ctx : extraction_ctx) (fmt : F.formatter) (* Add the type and const generic params - note that we need those bindings only for the * body translation (they are not top-level) *) let ctx, type_params, cg_params, trait_clauses = - ctx_add_generic_params decl.meta decl.llbc_name decl.llbc_generics generics ctx + ctx_add_generic_params decl.meta decl.llbc_name decl.llbc_generics generics + ctx in - extract_generic_params decl.meta ctx fmt TypeDeclId.Set.empty generics type_params - cg_params trait_clauses; + extract_generic_params decl.meta ctx fmt TypeDeclId.Set.empty generics + type_params cg_params trait_clauses; F.pp_print_space fmt (); if is_empty && !backend = FStar then ( @@ -2379,11 +2428,13 @@ let extract_trait_decl (ctx : extraction_ctx) (fmt : F.formatter) List.iter (fun clause -> let item_name = - ctx_get_trait_item_clause decl.meta decl.def_id name clause.clause_id ctx + ctx_get_trait_item_clause decl.meta decl.def_id name + clause.clause_id ctx in let ty () = F.pp_print_space fmt (); - extract_trait_clause_type decl.meta ctx fmt TypeDeclId.Set.empty clause + extract_trait_clause_type decl.meta ctx fmt TypeDeclId.Set.empty + clause in extract_trait_decl_item ctx fmt item_name ty) clauses) @@ -2398,7 +2449,8 @@ let extract_trait_decl (ctx : extraction_ctx) (fmt : F.formatter) in let ty () = F.pp_print_space fmt (); - extract_trait_clause_type decl.meta ctx fmt TypeDeclId.Set.empty clause + extract_trait_clause_type decl.meta ctx fmt TypeDeclId.Set.empty + clause in extract_trait_decl_item ctx fmt item_name ty) decl.parent_clauses; @@ -2453,7 +2505,8 @@ let extract_trait_decl_coq_arguments (ctx : extraction_ctx) (fmt : F.formatter) List.iter (fun clause -> let item_name = - ctx_get_trait_item_clause decl.meta decl.def_id name clause.clause_id ctx + ctx_get_trait_item_clause decl.meta decl.def_id name + clause.clause_id ctx in extract_coq_arguments_instruction ctx fmt item_name num_params) clauses) @@ -2470,7 +2523,9 @@ let extract_trait_decl_coq_arguments (ctx : extraction_ctx) (fmt : F.formatter) List.iter (fun (item_name, _) -> (* Extract the items *) - let item_name = ctx_get_trait_method decl.meta decl.def_id item_name ctx in + let item_name = + ctx_get_trait_method decl.meta decl.def_id item_name ctx + in extract_coq_arguments_instruction ctx fmt item_name num_params) decl.required_methods; (* Add a space *) @@ -2535,12 +2590,12 @@ let extract_trait_impl_method_items (ctx : extraction_ctx) (fmt : F.formatter) - we only generate trait clauses for the clauses we find in the pure generics *) let ctx, f_tys, f_cgs, f_tcs = - ctx_add_generic_params impl.meta f.llbc_name f.signature.llbc_generics f_generics - ctx + ctx_add_generic_params impl.meta f.llbc_name f.signature.llbc_generics + f_generics ctx in let use_forall = f_generics <> empty_generic_params in - extract_generic_params impl.meta ctx fmt TypeDeclId.Set.empty ~use_forall f_generics - f_tys f_cgs f_tcs; + extract_generic_params impl.meta ctx fmt TypeDeclId.Set.empty ~use_forall + f_generics f_tys f_cgs f_tcs; if use_forall then F.pp_print_string fmt ","; (* Extract the function call *) F.pp_print_space fmt (); @@ -2607,17 +2662,19 @@ let extract_trait_impl (ctx : extraction_ctx) (fmt : F.formatter) (* Add the type and const generic params - note that we need those bindings only for the * body translation (they are not top-level) *) let ctx, type_params, cg_params, trait_clauses = - ctx_add_generic_params impl.meta impl.llbc_name impl.llbc_generics impl.generics ctx + ctx_add_generic_params impl.meta impl.llbc_name impl.llbc_generics + impl.generics ctx in let all_generics = (type_params, cg_params, trait_clauses) in - extract_generic_params impl.meta ctx fmt TypeDeclId.Set.empty impl.generics type_params - cg_params trait_clauses; + extract_generic_params impl.meta ctx fmt TypeDeclId.Set.empty impl.generics + type_params cg_params trait_clauses; (* Print the type *) F.pp_print_space fmt (); F.pp_print_string fmt ":"; F.pp_print_space fmt (); - extract_trait_decl_ref impl.meta ctx fmt TypeDeclId.Set.empty false impl.impl_trait; + extract_trait_decl_ref impl.meta ctx fmt TypeDeclId.Set.empty false + impl.impl_trait; (* When checking if the trait impl is empty: we ignore the provided methods, because for now they are extracted separately *) @@ -2630,7 +2687,9 @@ let extract_trait_impl (ctx : extraction_ctx) (fmt : F.formatter) F.pp_close_box fmt ()) else if is_empty && !Config.backend = Coq then ( (* Coq is not very good at infering constructors *) - let cons = ctx_get_trait_constructor impl.meta impl.impl_trait.trait_decl_id ctx in + let cons = + ctx_get_trait_constructor impl.meta impl.impl_trait.trait_decl_id ctx + in F.pp_print_string fmt (":= " ^ cons ^ "."); (* Outer box *) F.pp_close_box fmt ()) @@ -2694,11 +2753,13 @@ let extract_trait_impl (ctx : extraction_ctx) (fmt : F.formatter) TraitClauseId.iteri (fun clause_id trait_ref -> let item_name = - ctx_get_trait_item_clause impl.meta trait_decl_id name clause_id ctx + ctx_get_trait_item_clause impl.meta trait_decl_id name clause_id + ctx in let ty () = F.pp_print_space fmt (); - extract_trait_ref impl.meta ctx fmt TypeDeclId.Set.empty false trait_ref + extract_trait_ref impl.meta ctx fmt TypeDeclId.Set.empty false + trait_ref in extract_trait_impl_item ctx fmt item_name ty) trait_refs) @@ -2712,7 +2773,8 @@ let extract_trait_impl (ctx : extraction_ctx) (fmt : F.formatter) in let ty () = F.pp_print_space fmt (); - extract_trait_ref impl.meta ctx fmt TypeDeclId.Set.empty false trait_ref + extract_trait_ref impl.meta ctx fmt TypeDeclId.Set.empty false + trait_ref in extract_trait_impl_item ctx fmt item_name ty) impl.parent_trait_refs; @@ -2775,7 +2837,9 @@ let extract_unit_test_if_unit_fun (ctx : extraction_ctx) (fmt : F.formatter) F.pp_print_string fmt "assert_norm"; F.pp_print_space fmt (); F.pp_print_string fmt "("; - let fun_name = ctx_get_local_function def.meta def.def_id def.loop_id ctx in + let fun_name = + ctx_get_local_function def.meta def.def_id def.loop_id ctx + in F.pp_print_string fmt fun_name; if sg.inputs <> [] then ( F.pp_print_space fmt (); @@ -2783,13 +2847,17 @@ 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 def.meta (TAssumed TResult) result_return_id ctx in + let success = + ctx_get_variant def.meta (TAssumed TResult) result_return_id ctx + in F.pp_print_string fmt (success ^ " ())") | Coq -> F.pp_print_string fmt "Check"; F.pp_print_space fmt (); F.pp_print_string fmt "("; - let fun_name = ctx_get_local_function def.meta def.def_id def.loop_id ctx in + let fun_name = + ctx_get_local_function def.meta def.def_id def.loop_id ctx + in F.pp_print_string fmt fun_name; if sg.inputs <> [] then ( F.pp_print_space fmt (); @@ -2800,7 +2868,9 @@ let extract_unit_test_if_unit_fun (ctx : extraction_ctx) (fmt : F.formatter) F.pp_print_string fmt "#assert"; F.pp_print_space fmt (); F.pp_print_string fmt "("; - let fun_name = ctx_get_local_function def.meta def.def_id def.loop_id ctx in + let fun_name = + ctx_get_local_function def.meta def.def_id def.loop_id ctx + in F.pp_print_string fmt fun_name; if sg.inputs <> [] then ( F.pp_print_space fmt (); @@ -2808,12 +2878,16 @@ 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 def.meta (TAssumed TResult) result_return_id ctx in + let success = + ctx_get_variant def.meta (TAssumed TResult) result_return_id ctx + in F.pp_print_string fmt (success ^ " ())") | HOL4 -> F.pp_print_string fmt "val _ = assert_return ("; F.pp_print_string fmt "“"; - let fun_name = ctx_get_local_function def.meta def.def_id def.loop_id ctx in + let fun_name = + ctx_get_local_function def.meta def.def_id def.loop_id ctx + in F.pp_print_string fmt fun_name; if sg.inputs <> [] then ( F.pp_print_space fmt (); diff --git a/compiler/ExtractBase.ml b/compiler/ExtractBase.ml index aae11f19..b7255dbc 100644 --- a/compiler/ExtractBase.ml +++ b/compiler/ExtractBase.ml @@ -237,7 +237,7 @@ module IdSet = Collections.MakeSet (IdOrderedType) *) type names_map = { id_to_name : string IdMap.t; - name_to_id : id StringMap.t; + name_to_id : (id * Meta.meta option) StringMap.t; (** The name to id map is used to look for name clashes, and generate nice debugging messages: if there is a name clash, it is useful to know precisely which identifiers are mapped to the same name... @@ -253,8 +253,8 @@ let empty_names_map : names_map = } (** Small helper to report name collision *) -let report_name_collision (id_to_string : id -> string) (id1 : id) (id2 : id) - (name : string) : unit = +let report_name_collision (id_to_string : id -> string) + ((id1, meta) : id * Meta.meta option) (id2 : id) (name : string) : unit = let id1 = "\n- " ^ id_to_string id1 in let id2 = "\n- " ^ id_to_string id2 in let err = @@ -263,9 +263,10 @@ let report_name_collision (id_to_string : id -> string) (id1 : id) (id2 : id) ^ "\nYou may want to rename some of your definitions, or report an issue." in (* If we fail hard on errors, raise an exception *) - save_error None err + save_error meta err -let names_map_get_id_from_name (name : string) (nm : names_map) : id option = +let names_map_get_id_from_name (name : string) (nm : names_map) : + (id * meta option) option = StringMap.find_opt name nm.name_to_id let names_map_check_collision (id_to_string : id -> string) (id : id) @@ -290,13 +291,13 @@ let names_map_add (id_to_string : id -> string) (id : id) (name : string) (* Check if there is a clash *) names_map_check_collision id_to_string id name nm; (* Sanity check *) - if StringSet.mem name nm.names_set then ( - let err = - "Error when registering the name for id: " ^ id_to_string id - ^ ":\nThe chosen name is already in the names set: " ^ name - in - (* If we fail hard on errors, raise an exception *) - save_error None err); + (if StringSet.mem name nm.names_set then + let err = + "Error when registering the name for id: " ^ id_to_string id + ^ ":\nThe chosen name is already in the names set: " ^ name + in + (* If we fail hard on errors, raise an exception *) + save_error None err); (* Insert *) names_map_add_unchecked id name nm @@ -423,8 +424,8 @@ let names_maps_add (id_to_string : id -> string) (id : id) (name : string) (** The [id_to_string] function to print nice debugging messages if there are collisions *) -let names_maps_get (meta : Meta.meta option) (id_to_string : id -> string) (id : id) (nm : names_maps) : - string = +let names_maps_get (meta : Meta.meta option) (id_to_string : id -> string) + (id : id) (nm : names_maps) : string = (* We do not use the same name map if we allow/disallow collisions *) let map_to_string (m : string IdMap.t) : string = "[\n" @@ -588,16 +589,17 @@ let fun_id_to_string (ctx : extraction_ctx) = PrintPure.regular_fun_id_to_string (extraction_ctx_to_fmt_env ctx) let adt_variant_to_string (meta : Meta.meta option) (ctx : extraction_ctx) = - PrintPure.adt_variant_to_string ~meta:meta (extraction_ctx_to_fmt_env ctx) + PrintPure.adt_variant_to_string ~meta (extraction_ctx_to_fmt_env ctx) let adt_field_to_string (meta : Meta.meta option) (ctx : extraction_ctx) = - PrintPure.adt_field_to_string ~meta:meta (extraction_ctx_to_fmt_env ctx) + PrintPure.adt_field_to_string ~meta (extraction_ctx_to_fmt_env ctx) (** Debugging function, used when communicating name collisions to the user, and also to print ids for internal debugging (in case of lookup miss for instance). *) -let id_to_string (meta : Meta.meta option) (id : id) (ctx : extraction_ctx) : string = +let id_to_string (meta : Meta.meta option) (id : id) (ctx : extraction_ctx) : + string = let trait_decl_id_to_string (id : A.TraitDeclId.id) : string = let trait_name = trait_decl_id_to_string ctx id in "trait_decl: " ^ trait_name ^ " (id: " ^ A.TraitDeclId.to_string id ^ ")" @@ -655,95 +657,108 @@ let id_to_string (meta : Meta.meta option) (id : id) (ctx : extraction_ctx) : st trait_decl_id_to_string trait_decl_id ^ ", method name: " ^ fun_name | TraitSelfClauseId -> "trait_self_clause" -let ctx_add (meta : Meta.meta) (id : id) (name : string) (ctx : extraction_ctx) : extraction_ctx = +let ctx_add (meta : Meta.meta) (id : id) (name : string) (ctx : extraction_ctx) + : extraction_ctx = let id_to_string (id : id) : string = id_to_string (Some meta) id ctx in let names_maps = names_maps_add id_to_string id name ctx.names_maps in { ctx with names_maps } -let ctx_get (meta : Meta.meta option) (id : id) (ctx : extraction_ctx) : string = +let ctx_get (meta : Meta.meta option) (id : id) (ctx : extraction_ctx) : string + = let id_to_string (id : id) : string = id_to_string meta id ctx in names_maps_get meta id_to_string id ctx.names_maps -let ctx_get_global (meta : Meta.meta) (id : A.GlobalDeclId.id) (ctx : extraction_ctx) : string = +let ctx_get_global (meta : Meta.meta) (id : A.GlobalDeclId.id) + (ctx : extraction_ctx) : string = ctx_get (Some meta) (GlobalId id) ctx -let ctx_get_function (meta : Meta.meta) (id : fun_id) (ctx : extraction_ctx) : string = +let ctx_get_function (meta : Meta.meta) (id : fun_id) (ctx : extraction_ctx) : + string = ctx_get (Some meta) (FunId id) ctx -let ctx_get_local_function (meta : Meta.meta) (id : A.FunDeclId.id) (lp : LoopId.id option) - (ctx : extraction_ctx) : string = +let ctx_get_local_function (meta : Meta.meta) (id : A.FunDeclId.id) + (lp : LoopId.id option) (ctx : extraction_ctx) : string = ctx_get_function meta (FromLlbc (FunId (FRegular id), lp)) ctx -let ctx_get_type (meta : Meta.meta option) (id : type_id) (ctx : extraction_ctx) : string = +let ctx_get_type (meta : Meta.meta option) (id : type_id) (ctx : extraction_ctx) + : string = sanity_check_opt_meta (id <> TTuple) meta; ctx_get meta (TypeId id) ctx -let ctx_get_local_type (meta : Meta.meta) (id : TypeDeclId.id) (ctx : extraction_ctx) : string = +let ctx_get_local_type (meta : Meta.meta) (id : TypeDeclId.id) + (ctx : extraction_ctx) : string = ctx_get_type (Some meta) (TAdtId id) ctx -let ctx_get_assumed_type (meta : Meta.meta option) (id : assumed_ty) (ctx : extraction_ctx) : string = +let ctx_get_assumed_type (meta : Meta.meta option) (id : assumed_ty) + (ctx : extraction_ctx) : string = ctx_get_type meta (TAssumed id) ctx -let ctx_get_trait_constructor (meta : Meta.meta) (id : trait_decl_id) (ctx : extraction_ctx) : - string = +let ctx_get_trait_constructor (meta : Meta.meta) (id : trait_decl_id) + (ctx : extraction_ctx) : string = ctx_get (Some meta) (TraitDeclConstructorId id) ctx -let ctx_get_trait_self_clause (meta : Meta.meta) (ctx : extraction_ctx) : string = +let ctx_get_trait_self_clause (meta : Meta.meta) (ctx : extraction_ctx) : string + = ctx_get (Some meta) TraitSelfClauseId ctx -let ctx_get_trait_decl (meta : Meta.meta) (id : trait_decl_id) (ctx : extraction_ctx) : string = +let ctx_get_trait_decl (meta : Meta.meta) (id : trait_decl_id) + (ctx : extraction_ctx) : string = ctx_get (Some meta) (TraitDeclId id) ctx -let ctx_get_trait_impl (meta : Meta.meta) (id : trait_impl_id) (ctx : extraction_ctx) : string = +let ctx_get_trait_impl (meta : Meta.meta) (id : trait_impl_id) + (ctx : extraction_ctx) : string = ctx_get (Some meta) (TraitImplId id) ctx -let ctx_get_trait_item (meta : Meta.meta) (id : trait_decl_id) (item_name : string) - (ctx : extraction_ctx) : string = - ctx_get (Some meta) (TraitItemId (id, item_name)) ctx +let ctx_get_trait_item (meta : Meta.meta) (id : trait_decl_id) + (item_name : string) (ctx : extraction_ctx) : string = + ctx_get (Some meta) (TraitItemId (id, item_name)) ctx -let ctx_get_trait_const (meta : Meta.meta) (id : trait_decl_id) (item_name : string) - (ctx : extraction_ctx) : string = +let ctx_get_trait_const (meta : Meta.meta) (id : trait_decl_id) + (item_name : string) (ctx : extraction_ctx) : string = ctx_get_trait_item meta id item_name ctx -let ctx_get_trait_type (meta : Meta.meta) (id : trait_decl_id) (item_name : string) - (ctx : extraction_ctx) : string = +let ctx_get_trait_type (meta : Meta.meta) (id : trait_decl_id) + (item_name : string) (ctx : extraction_ctx) : string = ctx_get_trait_item meta id item_name ctx -let ctx_get_trait_method (meta : Meta.meta) (id : trait_decl_id) (item_name : string) - (ctx : extraction_ctx) : string = +let ctx_get_trait_method (meta : Meta.meta) (id : trait_decl_id) + (item_name : string) (ctx : extraction_ctx) : string = ctx_get (Some meta) (TraitMethodId (id, item_name)) ctx -let ctx_get_trait_parent_clause (meta : Meta.meta) (id : trait_decl_id) (clause : trait_clause_id) - (ctx : extraction_ctx) : string = +let ctx_get_trait_parent_clause (meta : Meta.meta) (id : trait_decl_id) + (clause : trait_clause_id) (ctx : extraction_ctx) : string = ctx_get (Some meta) (TraitParentClauseId (id, clause)) ctx -let ctx_get_trait_item_clause (meta : Meta.meta) (id : trait_decl_id) (item : string) - (clause : trait_clause_id) (ctx : extraction_ctx) : string = +let ctx_get_trait_item_clause (meta : Meta.meta) (id : trait_decl_id) + (item : string) (clause : trait_clause_id) (ctx : extraction_ctx) : string = ctx_get (Some meta) (TraitItemClauseId (id, item, clause)) ctx -let ctx_get_var (meta : Meta.meta) (id : VarId.id) (ctx : extraction_ctx) : string = +let ctx_get_var (meta : Meta.meta) (id : VarId.id) (ctx : extraction_ctx) : + string = ctx_get (Some meta) (VarId id) ctx -let ctx_get_type_var (meta : Meta.meta) (id : TypeVarId.id) (ctx : extraction_ctx) : string = +let ctx_get_type_var (meta : Meta.meta) (id : TypeVarId.id) + (ctx : extraction_ctx) : string = ctx_get (Some meta) (TypeVarId id) ctx -let ctx_get_const_generic_var (meta : Meta.meta) (id : ConstGenericVarId.id) (ctx : extraction_ctx) - : string = +let ctx_get_const_generic_var (meta : Meta.meta) (id : ConstGenericVarId.id) + (ctx : extraction_ctx) : string = ctx_get (Some meta) (ConstGenericVarId id) ctx -let ctx_get_local_trait_clause (meta : Meta.meta) (id : TraitClauseId.id) (ctx : extraction_ctx) : - string = +let ctx_get_local_trait_clause (meta : Meta.meta) (id : TraitClauseId.id) + (ctx : extraction_ctx) : string = ctx_get (Some meta) (LocalTraitClauseId id) ctx let ctx_get_field (meta : Meta.meta) (type_id : type_id) (field_id : FieldId.id) (ctx : extraction_ctx) : string = ctx_get (Some meta) (FieldId (type_id, field_id)) ctx -let ctx_get_struct (meta : Meta.meta) (def_id : type_id) (ctx : extraction_ctx) : string = +let ctx_get_struct (meta : Meta.meta) (def_id : type_id) (ctx : extraction_ctx) + : string = ctx_get (Some meta) (StructId def_id) ctx -let ctx_get_variant (meta : Meta.meta) (def_id : type_id) (variant_id : VariantId.id) - (ctx : extraction_ctx) : string = +let ctx_get_variant (meta : Meta.meta) (def_id : type_id) + (variant_id : VariantId.id) (ctx : extraction_ctx) : string = ctx_get (Some meta) (VariantId (def_id, variant_id)) ctx let ctx_get_decreases_proof (meta : Meta.meta) (def_id : A.FunDeclId.id) @@ -1187,11 +1202,10 @@ let type_decl_kind_to_qualif (meta : Meta.meta) (kind : decl_kind) (* This is for traits *) Some "Record" | _ -> - craise - meta - ("Unexpected: (" ^ show_decl_kind kind ^ ", " - ^ Print.option_to_string show_type_decl_kind type_kind - ^ ")")) + craise meta + ("Unexpected: (" ^ show_decl_kind kind ^ ", " + ^ Print.option_to_string show_type_decl_kind type_kind + ^ ")")) | Lean -> ( match kind with | SingleNonRec -> ( @@ -1264,20 +1278,20 @@ let name_last_elem_as_ident (meta : Meta.meta) (n : llbc_name) : string = we remove it. We ignore disambiguators (there may be collisions, but we check if there are). *) -let ctx_prepare_name (meta : Meta.meta) (ctx : extraction_ctx) (name : llbc_name) : llbc_name = +let ctx_prepare_name (meta : Meta.meta) (ctx : extraction_ctx) + (name : llbc_name) : llbc_name = (* Rmk.: initially we only filtered the disambiguators equal to 0 *) match name with | (PeIdent (crate, _) as id) :: name -> if crate = ctx.crate.name then name else id :: name | _ -> - craise - meta - ("Unexpected name shape: " - ^ TranslateCore.name_to_string ctx.trans_ctx name) + craise meta + ("Unexpected name shape: " + ^ TranslateCore.name_to_string ctx.trans_ctx name) (** Helper *) -let ctx_compute_simple_name (meta : Meta.meta) (ctx : extraction_ctx) (name : llbc_name) : - string list = +let ctx_compute_simple_name (meta : Meta.meta) (ctx : extraction_ctx) + (name : llbc_name) : string list = (* Rmk.: initially we only filtered the disambiguators equal to 0 *) let name = ctx_prepare_name meta ctx name in name_to_simple_name ctx.trans_ctx name @@ -1287,12 +1301,13 @@ let ctx_compute_simple_type_name = ctx_compute_simple_name (** Helper *) -let ctx_compute_type_name_no_suffix (meta : Meta.meta) (ctx : extraction_ctx) (name : llbc_name) : - string = +let ctx_compute_type_name_no_suffix (meta : Meta.meta) (ctx : extraction_ctx) + (name : llbc_name) : string = flatten_name (ctx_compute_simple_type_name meta ctx name) (** Provided a basename, compute a type name. *) -let ctx_compute_type_name (meta : Meta.meta) (ctx : extraction_ctx) (name : llbc_name) = +let ctx_compute_type_name (meta : Meta.meta) (ctx : extraction_ctx) + (name : llbc_name) = let name = ctx_compute_type_name_no_suffix meta ctx name in match !backend with | FStar -> StringUtils.lowercase_first_letter (name ^ "_t") @@ -1310,8 +1325,9 @@ let ctx_compute_type_name (meta : Meta.meta) (ctx : extraction_ctx) (name : llbc access then causes trouble because not all provers accept syntax like [x.3] where [x] is a tuple. *) -let ctx_compute_field_name (meta : Meta.meta) (ctx : extraction_ctx) (def_name : llbc_name) - (field_id : FieldId.id) (field_name : string option) : string = +let ctx_compute_field_name (meta : Meta.meta) (ctx : extraction_ctx) + (def_name : llbc_name) (field_id : FieldId.id) (field_name : string option) + : string = let field_name_s = match field_name with | Some field_name -> field_name @@ -1335,8 +1351,8 @@ let ctx_compute_field_name (meta : Meta.meta) (ctx : extraction_ctx) (def_name : - type name - variant name *) -let ctx_compute_variant_name (meta : Meta.meta) (ctx : extraction_ctx) (def_name : llbc_name) - (variant : string) : string = +let ctx_compute_variant_name (meta : Meta.meta) (ctx : extraction_ctx) + (def_name : llbc_name) (variant : string) : string = match !backend with | FStar | Coq | HOL4 -> let variant = to_camel_case variant in @@ -1357,13 +1373,13 @@ let ctx_compute_variant_name (meta : Meta.meta) (ctx : extraction_ctx) (def_name Inputs: - type name *) -let ctx_compute_struct_constructor (meta : Meta.meta) (ctx : extraction_ctx) (basename : llbc_name) - : string = +let ctx_compute_struct_constructor (meta : Meta.meta) (ctx : extraction_ctx) + (basename : llbc_name) : string = let tname = ctx_compute_type_name meta ctx basename in ExtractBuiltin.mk_struct_constructor tname -let ctx_compute_fun_name_no_suffix (meta : Meta.meta) (ctx : extraction_ctx) (fname : llbc_name) : - string = +let ctx_compute_fun_name_no_suffix (meta : Meta.meta) (ctx : extraction_ctx) + (fname : llbc_name) : string = let fname = ctx_compute_simple_name meta ctx fname in (* TODO: don't convert to snake case for Coq, HOL4, F* *) let fname = flatten_name fname in @@ -1372,10 +1388,13 @@ let ctx_compute_fun_name_no_suffix (meta : Meta.meta) (ctx : extraction_ctx) (fn | Lean -> fname (** Provided a basename, compute the name of a global declaration. *) -let ctx_compute_global_name (meta : Meta.meta) (ctx : extraction_ctx) (name : llbc_name) : string = +let ctx_compute_global_name (meta : Meta.meta) (ctx : extraction_ctx) + (name : llbc_name) : string = match !Config.backend with | Coq | FStar | HOL4 -> - let parts = List.map to_snake_case (ctx_compute_simple_name meta ctx name) in + let parts = + List.map to_snake_case (ctx_compute_simple_name meta ctx name) + in String.concat "_" parts | Lean -> flatten_name (ctx_compute_simple_name meta ctx name) @@ -1408,8 +1427,9 @@ let default_fun_suffix (num_loops : int) (loop_id : LoopId.id option) : string = - loop id (if pertinent) TODO: use the fun id for the assumed functions. *) -let ctx_compute_fun_name (meta : Meta.meta) (ctx : extraction_ctx) (fname : llbc_name) - (num_loops : int) (loop_id : LoopId.id option) : string = +let ctx_compute_fun_name (meta : Meta.meta) (ctx : extraction_ctx) + (fname : llbc_name) (num_loops : int) (loop_id : LoopId.id option) : string + = let fname = ctx_compute_fun_name_no_suffix meta ctx fname in (* Compute the suffix *) let suffix = default_fun_suffix num_loops loop_id in @@ -1568,9 +1588,9 @@ let ctx_compute_trait_type_clause_name (ctx : extraction_ctx) the same purpose as in [llbc_name]. - loop identifier, if this is for a loop *) -let ctx_compute_termination_measure_name (meta : Meta.meta) (ctx : extraction_ctx) - (_fid : A.FunDeclId.id) (fname : llbc_name) (num_loops : int) - (loop_id : LoopId.id option) : string = +let ctx_compute_termination_measure_name (meta : Meta.meta) + (ctx : extraction_ctx) (_fid : A.FunDeclId.id) (fname : llbc_name) + (num_loops : int) (loop_id : LoopId.id option) : string = let fname = ctx_compute_fun_name_no_suffix meta ctx fname in let lp_suffix = default_fun_loop_suffix num_loops loop_id in (* Compute the suffix *) @@ -1624,8 +1644,8 @@ let ctx_compute_decreases_proof_name (meta : Meta.meta) (ctx : extraction_ctx) if necessary to prevent name clashes: the burden of name clashes checks is thus on the caller's side. *) -let ctx_compute_var_basename (meta : Meta.meta) (ctx : extraction_ctx) (basename : string option) - (ty : ty) : string = +let ctx_compute_var_basename (meta : Meta.meta) (ctx : extraction_ctx) + (basename : string option) (ty : ty) : string = (* Small helper to derive var names from ADT type names. We do the following: @@ -1747,8 +1767,9 @@ let ctx_add_type_var (meta : Meta.meta) (basename : string) (id : TypeVarId.id) (ctx, name) (** Generate a unique const generic variable name and add it to the context *) -let ctx_add_const_generic_var (meta : Meta.meta) (basename : string) (id : ConstGenericVarId.id) - (ctx : extraction_ctx) : extraction_ctx * string = +let ctx_add_const_generic_var (meta : Meta.meta) (basename : string) + (id : ConstGenericVarId.id) (ctx : extraction_ctx) : extraction_ctx * string + = let name = ctx_compute_const_generic_var_basename ctx basename in let name = basename_to_unique ctx.names_maps.names_map.names_set name_append_index name @@ -1764,8 +1785,8 @@ let ctx_add_type_vars (meta : Meta.meta) (vars : (string * TypeVarId.id) list) ctx vars (** Generate a unique variable name and add it to the context *) -let ctx_add_var (meta : Meta.meta) (basename : string) (id : VarId.id) (ctx : extraction_ctx) : - extraction_ctx * string = +let ctx_add_var (meta : Meta.meta) (basename : string) (id : VarId.id) + (ctx : extraction_ctx) : extraction_ctx * string = let name = basename_to_unique ctx.names_maps.names_map.names_set name_append_index basename @@ -1774,7 +1795,8 @@ let ctx_add_var (meta : Meta.meta) (basename : string) (id : VarId.id) (ctx : ex (ctx, name) (** Generate a unique variable name for the trait self clause and add it to the context *) -let ctx_add_trait_self_clause (meta : Meta.meta) (ctx : extraction_ctx) : extraction_ctx * string = +let ctx_add_trait_self_clause (meta : Meta.meta) (ctx : extraction_ctx) : + extraction_ctx * string = let basename = trait_self_clause_basename in let name = basename_to_unique ctx.names_maps.names_map.names_set name_append_index @@ -1784,8 +1806,8 @@ let ctx_add_trait_self_clause (meta : Meta.meta) (ctx : extraction_ctx) : extrac (ctx, name) (** Generate a unique trait clause name and add it to the context *) -let ctx_add_local_trait_clause (meta : Meta.meta) (basename : string) (id : TraitClauseId.id) - (ctx : extraction_ctx) : extraction_ctx * string = +let ctx_add_local_trait_clause (meta : Meta.meta) (basename : string) + (id : TraitClauseId.id) (ctx : extraction_ctx) : extraction_ctx * string = let name = basename_to_unique ctx.names_maps.names_map.names_set name_append_index basename @@ -1802,14 +1824,15 @@ let ctx_add_vars (meta : Meta.meta) (vars : var list) (ctx : extraction_ctx) : ctx_add_var meta name v.id ctx) ctx vars -let ctx_add_type_params (meta : Meta.meta) (vars : type_var list) (ctx : extraction_ctx) : - extraction_ctx * string list = +let ctx_add_type_params (meta : Meta.meta) (vars : type_var list) + (ctx : extraction_ctx) : extraction_ctx * string list = List.fold_left_map (fun ctx (var : type_var) -> ctx_add_type_var meta var.name var.index ctx) ctx vars -let ctx_add_const_generic_params (meta : Meta.meta) (vars : const_generic_var list) - (ctx : extraction_ctx) : extraction_ctx * string list = +let ctx_add_const_generic_params (meta : Meta.meta) + (vars : const_generic_var list) (ctx : extraction_ctx) : + extraction_ctx * string list = List.fold_left_map (fun ctx (var : const_generic_var) -> ctx_add_const_generic_var meta var.name var.index ctx) @@ -1824,9 +1847,10 @@ let ctx_add_const_generic_params (meta : Meta.meta) (vars : const_generic_var li pretty names for the trait clauses. See {!ctx_compute_trait_clause_name} for additional information. *) -let ctx_add_local_trait_clauses (meta : Meta.meta) (current_def_name : Types.name) - (llbc_generics : Types.generic_params) (clauses : trait_clause list) - (ctx : extraction_ctx) : extraction_ctx * string list = +let ctx_add_local_trait_clauses (meta : Meta.meta) + (current_def_name : Types.name) (llbc_generics : Types.generic_params) + (clauses : trait_clause list) (ctx : extraction_ctx) : + extraction_ctx * string list = List.fold_left_map (fun ctx (c : trait_clause) -> let basename = @@ -1853,17 +1877,20 @@ let ctx_add_generic_params (meta : Meta.meta) (current_def_name : Types.name) let ctx, tys = ctx_add_type_params meta types ctx in let ctx, cgs = ctx_add_const_generic_params meta const_generics ctx in let ctx, tcs = - ctx_add_local_trait_clauses meta current_def_name llbc_generics trait_clauses ctx + ctx_add_local_trait_clauses meta current_def_name llbc_generics + trait_clauses ctx in (ctx, tys, cgs, tcs) let ctx_add_decreases_proof (def : fun_decl) (ctx : extraction_ctx) : extraction_ctx = let name = - ctx_compute_decreases_proof_name def.meta ctx def.def_id def.llbc_name def.num_loops - def.loop_id + ctx_compute_decreases_proof_name def.meta ctx def.def_id def.llbc_name + def.num_loops def.loop_id in - ctx_add def.meta (DecreasesProofId (FRegular def.def_id, def.loop_id)) name ctx + ctx_add def.meta + (DecreasesProofId (FRegular def.def_id, def.loop_id)) + name ctx let ctx_add_termination_measure (def : fun_decl) (ctx : extraction_ctx) : extraction_ctx = @@ -1871,7 +1898,9 @@ let ctx_add_termination_measure (def : fun_decl) (ctx : extraction_ctx) : ctx_compute_termination_measure_name def.meta ctx def.def_id def.llbc_name def.num_loops def.loop_id in - ctx_add def.meta (TerminationMeasureId (FRegular def.def_id, def.loop_id)) name ctx + ctx_add def.meta + (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 = diff --git a/compiler/ExtractName.ml b/compiler/ExtractName.ml index c4e145a0..e9d6116f 100644 --- a/compiler/ExtractName.ml +++ b/compiler/ExtractName.ml @@ -32,7 +32,8 @@ end For impl blocks, we simply use the name of the type (without its arguments) if all the arguments are variables. *) -let pattern_to_extract_name (meta : Meta.meta option) (name : pattern) : string list = +let pattern_to_extract_name (meta : Meta.meta option) (name : pattern) : + string list = let c = { tgt = TkName } in let all_vars = let check (g : generic_arg) : bool = diff --git a/compiler/ExtractTypes.ml b/compiler/ExtractTypes.ml index 94acd08c..d785e299 100644 --- a/compiler/ExtractTypes.ml +++ b/compiler/ExtractTypes.ml @@ -15,7 +15,8 @@ include ExtractBase if it is made of an application (ex.: [U32 3]) - the constant value *) -let extract_literal (meta : Meta.meta) (fmt : F.formatter) (inside : bool) (cv : literal) : unit = +let extract_literal (meta : Meta.meta) (fmt : F.formatter) (inside : bool) + (cv : literal) : unit = match cv with | VScalar sv -> ( match !backend with @@ -187,9 +188,10 @@ let extract_unop (meta : Meta.meta) (extract_expr : bool -> texpression -> unit) - argument 0 - argument 1 *) -let extract_binop (meta : Meta.meta) (extract_expr : bool -> texpression -> unit) - (fmt : F.formatter) (inside : bool) (binop : E.binop) - (int_ty : integer_type) (arg0 : texpression) (arg1 : texpression) : unit = +let extract_binop (meta : Meta.meta) + (extract_expr : bool -> texpression -> unit) (fmt : F.formatter) + (inside : bool) (binop : E.binop) (int_ty : integer_type) + (arg0 : texpression) (arg1 : texpression) : unit = if inside then F.pp_print_string fmt "("; (* Some binary operations have a special notation depending on the backend *) (match (!backend, binop) with @@ -392,8 +394,8 @@ let extract_arrow (fmt : F.formatter) () : unit = if !Config.backend = Lean then F.pp_print_string fmt "→" else F.pp_print_string fmt "->" -let extract_const_generic (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) - (inside : bool) (cg : const_generic) : unit = +let extract_const_generic (meta : Meta.meta) (ctx : extraction_ctx) + (fmt : F.formatter) (inside : bool) (cg : const_generic) : unit = match cg with | CgGlobal id -> let s = ctx_get_global meta id ctx in @@ -496,7 +498,9 @@ let rec extract_ty (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) | HOL4 -> let { types; const_generics; trait_refs } = generics in (* Const generics are not supported in HOL4 *) - cassert (const_generics = []) meta "Constant generics are not supported yet when generating code for HOL4"; + cassert (const_generics = []) meta + "Constant generics are not supported yet when generating code \ + for HOL4"; let print_tys = match type_id with | TAdtId id -> not (TypeDeclId.Set.mem id no_params_tys) @@ -533,8 +537,8 @@ let rec extract_ty (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) if !parameterize_trait_types then craise meta "Unimplemented" else let type_name = - ctx_get_trait_type meta trait_ref.trait_decl_ref.trait_decl_id type_name - ctx + ctx_get_trait_type meta trait_ref.trait_decl_ref.trait_decl_id + type_name ctx in let add_brackets (s : string) = if !backend = Coq then "(" ^ s ^ ")" else s @@ -548,18 +552,22 @@ let rec extract_ty (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) *) match trait_ref.trait_id with | Self -> - cassert (trait_ref.generics = empty_generic_args) meta "TODO: Error message"; + cassert + (trait_ref.generics = empty_generic_args) + meta "TODO: Error message"; extract_trait_instance_id_with_dot meta ctx fmt no_params_tys false trait_ref.trait_id; F.pp_print_string fmt type_name | _ -> (* HOL4 doesn't have 1st class types *) - cassert (!backend <> HOL4) meta "Trait types are not supported yet when generating code for HOL4"; + cassert (!backend <> HOL4) meta + "Trait types are not supported yet when generating code for HOL4"; extract_trait_ref meta ctx fmt no_params_tys false trait_ref; F.pp_print_string fmt ("." ^ add_brackets type_name)) -and extract_trait_ref (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) - (no_params_tys : TypeDeclId.Set.t) (inside : bool) (tr : trait_ref) : unit = +and extract_trait_ref (meta : Meta.meta) (ctx : extraction_ctx) + (fmt : F.formatter) (no_params_tys : TypeDeclId.Set.t) (inside : bool) + (tr : trait_ref) : unit = let use_brackets = tr.generics <> empty_generic_args && inside in if use_brackets then F.pp_print_string fmt "("; (* We may need to filter the parameters if the trait is builtin *) @@ -583,9 +591,9 @@ and extract_trait_ref (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatt extract_generic_args meta ctx fmt no_params_tys generics; if use_brackets then F.pp_print_string fmt ")" -and extract_trait_decl_ref (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) - (no_params_tys : TypeDeclId.Set.t) (inside : bool) (tr : trait_decl_ref) : - unit = +and extract_trait_decl_ref (meta : Meta.meta) (ctx : extraction_ctx) + (fmt : F.formatter) (no_params_tys : TypeDeclId.Set.t) (inside : bool) + (tr : trait_decl_ref) : unit = let use_brackets = tr.decl_generics <> empty_generic_args && inside in let name = ctx_get_trait_decl meta tr.trait_decl_id ctx in if use_brackets then F.pp_print_string fmt "("; @@ -596,8 +604,9 @@ and extract_trait_decl_ref (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.fo extract_generic_args meta ctx fmt no_params_tys generics; if use_brackets then F.pp_print_string fmt ")" -and extract_generic_args (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) - (no_params_tys : TypeDeclId.Set.t) (generics : generic_args) : unit = +and extract_generic_args (meta : Meta.meta) (ctx : extraction_ctx) + (fmt : F.formatter) (no_params_tys : TypeDeclId.Set.t) + (generics : generic_args) : unit = let { types; const_generics; trait_refs } = generics in if !backend <> HOL4 then ( if types <> [] then ( @@ -606,7 +615,8 @@ and extract_generic_args (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.form (extract_ty meta ctx fmt no_params_tys true) types); if const_generics <> [] then ( - cassert (!backend <> HOL4) meta "Constant generics are not supported yet when generating code for HOL4"; + cassert (!backend <> HOL4) meta + "Constant generics are not supported yet when generating code for HOL4"; F.pp_print_space fmt (); Collections.List.iter_link (F.pp_print_space fmt) (extract_const_generic meta ctx fmt true) @@ -653,9 +663,9 @@ and extract_trait_instance_id_with_dot (meta : Meta.meta) (ctx : extraction_ctx) extract_trait_instance_id meta ctx fmt no_params_tys inside id; F.pp_print_string fmt "." -and extract_trait_instance_id (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) - (no_params_tys : TypeDeclId.Set.t) (inside : bool) (id : trait_instance_id) - : unit = +and extract_trait_instance_id (meta : Meta.meta) (ctx : extraction_ctx) + (fmt : F.formatter) (no_params_tys : TypeDeclId.Set.t) (inside : bool) + (id : trait_instance_id) : unit = let add_brackets (s : string) = if !backend = Coq then "(" ^ s ^ ")" else s in match id with | Self -> @@ -676,7 +686,9 @@ and extract_trait_instance_id (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F F.pp_print_string fmt (add_brackets name) | ItemClause (inst_id, decl_id, item_name, clause_id) -> (* Use the trait decl id to lookup the name *) - let name = ctx_get_trait_item_clause meta decl_id item_name clause_id ctx in + let name = + ctx_get_trait_item_clause meta decl_id item_name clause_id ctx + in extract_trait_instance_id_with_dot meta ctx fmt no_params_tys true inst_id; F.pp_print_string fmt (add_brackets name) | TraitRef trait_ref -> @@ -760,10 +772,8 @@ let extract_type_decl_register_names (ctx : extraction_ctx) (def : type_decl) : in (field_names, cons_name) | Some info -> - craise - def.meta - ("Invalid builtin information: " - ^ show_builtin_type_info info) + craise def.meta + ("Invalid builtin information: " ^ show_builtin_type_info info) in (* Add the fields *) let ctx = @@ -822,10 +832,10 @@ let extract_type_decl_register_names (ctx : extraction_ctx) (def : type_decl) : ctx (** Print the variants *) -let extract_type_decl_variant (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) - (type_decl_group : TypeDeclId.Set.t) (type_name : string) - (type_params : string list) (cg_params : string list) (cons_name : string) - (fields : field list) : unit = +let extract_type_decl_variant (meta : Meta.meta) (ctx : extraction_ctx) + (fmt : F.formatter) (type_decl_group : TypeDeclId.Set.t) + (type_name : string) (type_params : string list) (cg_params : string list) + (cons_name : string) (fields : field list) : unit = F.pp_print_space fmt (); (* variant box *) F.pp_open_hvbox fmt ctx.indent_incr; @@ -932,18 +942,20 @@ let extract_type_decl_enum_body (ctx : extraction_ctx) (fmt : F.formatter) let print_variant _variant_id (v : variant) = (* We don't lookup the name, because it may have a prefix for the type id (in the case of Lean) *) - let cons_name = ctx_compute_variant_name def.meta ctx def.llbc_name v.variant_name in + let cons_name = + ctx_compute_variant_name def.meta ctx def.llbc_name v.variant_name + in let fields = v.fields in - extract_type_decl_variant def.meta ctx fmt type_decl_group def_name type_params - cg_params cons_name fields + extract_type_decl_variant def.meta ctx fmt type_decl_group def_name + type_params cg_params cons_name fields in (* Print the variants *) let variants = VariantId.mapi (fun vid v -> (vid, v)) variants in List.iter (fun (vid, v) -> print_variant vid v) variants (** Extract a struct as a tuple *) -let extract_type_decl_tuple_struct_body (meta : Meta.meta) (ctx : extraction_ctx) - (fmt : F.formatter) (fields : field list) : unit = +let extract_type_decl_tuple_struct_body (meta : Meta.meta) + (ctx : extraction_ctx) (fmt : F.formatter) (fields : field list) : unit = (* If the type is empty, we need to have a special treatment *) if fields = [] then ( F.pp_print_space fmt (); @@ -1046,7 +1058,9 @@ let extract_type_decl_struct_body (ctx : extraction_ctx) (fmt : F.formatter) | Lean -> F.pp_open_vbox fmt 0); (* Print the fields *) let print_field (field_id : FieldId.id) (f : field) : unit = - let field_name = ctx_get_field def.meta (TAdtId def.def_id) field_id ctx in + let field_name = + ctx_get_field def.meta (TAdtId def.def_id) field_id ctx + in (* Open a box for the field *) F.pp_open_box fmt ctx.indent_incr; F.pp_print_string fmt field_name; @@ -1075,17 +1089,21 @@ let extract_type_decl_struct_body (ctx : extraction_ctx) (fmt : F.formatter) else ( (* We extract for Coq or Lean, and we have a recursive record, or a record in a group of mutually recursive types: we extract it as an inductive type *) - cassert (is_rec && (!backend = Coq || !backend = Lean)) def.meta "Constant generics are not supported yet when generating code for HOL4"; + cassert + (is_rec && (!backend = Coq || !backend = Lean)) + def.meta + "Constant generics are not supported yet when generating code for HOL4"; (* Small trick: in Lean we use namespaces, meaning we don't need to prefix the constructor name with the name of the type at definition site, i.e., instead of generating `inductive Foo := | MkFoo ...` like in Coq we generate `inductive Foo := | mk ... *) let cons_name = - if !backend = Lean then "mk" else ctx_get_struct def.meta (TAdtId def.def_id) ctx + if !backend = Lean then "mk" + else ctx_get_struct def.meta (TAdtId def.def_id) ctx in let def_name = ctx_get_local_type def.meta def.def_id ctx in - extract_type_decl_variant def.meta ctx fmt type_decl_group def_name type_params - cg_params cons_name fields) + extract_type_decl_variant def.meta ctx fmt type_decl_group def_name + type_params cg_params cons_name fields) in () @@ -1129,12 +1147,14 @@ let extract_comment_with_span (ctx : extraction_ctx) (fmt : F.formatter) in extract_comment fmt (sl @ [ span ] @ name) -let extract_trait_clause_type (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) - (no_params_tys : TypeDeclId.Set.t) (clause : trait_clause) : unit = +let extract_trait_clause_type (meta : Meta.meta) (ctx : extraction_ctx) + (fmt : F.formatter) (no_params_tys : TypeDeclId.Set.t) + (clause : trait_clause) : unit = let trait_name = ctx_get_trait_decl meta clause.trait_id ctx in F.pp_print_string fmt trait_name; (* let meta = (TraitDeclId.Map.find clause.trait_id ctx.trans_trait_decls).meta in - *)extract_generic_args meta ctx fmt no_params_tys clause.generics + *) + extract_generic_args meta ctx fmt no_params_tys clause.generics (** Insert a space, if necessary *) let insert_req_space (fmt : F.formatter) (space : bool ref) : unit = @@ -1167,8 +1187,8 @@ let extract_trait_self_clause (insert_req_space : unit -> unit) - [trait_decl]: if [Some], it means we are extracting the generics for a provided method and need to insert a trait self clause (see {!TraitSelfClauseId}). *) -let extract_generic_params (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.formatter) - (no_params_tys : TypeDeclId.Set.t) ?(use_forall = false) +let extract_generic_params (meta : Meta.meta) (ctx : extraction_ctx) + (fmt : F.formatter) (no_params_tys : TypeDeclId.Set.t) ?(use_forall = false) ?(use_forall_use_sep = true) ?(use_arrows = false) ?(as_implicits : bool = false) ?(space : bool ref option = None) ?(trait_decl : trait_decl option = None) (generics : generic_params) @@ -1176,7 +1196,9 @@ let extract_generic_params (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.fo (trait_clauses : string list) : unit = let all_params = List.concat [ type_params; cg_params; trait_clauses ] in (* HOL4 doesn't support const generics *) - cassert (cg_params = [] || !backend <> HOL4) meta "Constant generics are not supported yet when generating code for HOL4"; + cassert + (cg_params = [] || !backend <> HOL4) + meta "Constant generics are not supported yet when generating code for HOL4"; let left_bracket (implicit : bool) = if implicit && !backend <> FStar then F.pp_print_string fmt "{" else F.pp_print_string fmt "(" @@ -1304,7 +1326,8 @@ let extract_generic_params (meta : Meta.meta) (ctx : extraction_ctx) (fmt : F.fo ctx_get_const_generic_var trait_decl.meta cg.index ctx) dcgs; map - (fun c -> ctx_get_local_trait_clause trait_decl.meta c.clause_id ctx) + (fun c -> + ctx_get_local_trait_clause trait_decl.meta c.clause_id ctx) dtrait_clauses; ] in @@ -1355,7 +1378,8 @@ let extract_type_decl_gen (ctx : extraction_ctx) (fmt : F.formatter) (* Add the type and const generic params - note that we need those bindings only for the * body translation (they are not top-level) *) let ctx_body, type_params, cg_params, trait_clauses = - ctx_add_generic_params def.meta def.llbc_name def.llbc_generics def.generics ctx + ctx_add_generic_params def.meta def.llbc_name def.llbc_generics def.generics + ctx in (* Add a break before *) if !backend <> HOL4 || not (decl_is_first_from_group kind) then @@ -1394,10 +1418,14 @@ let extract_type_decl_gen (ctx : extraction_ctx) (fmt : F.formatter) | None -> F.pp_print_string fmt def_name); (* HOL4 doesn't support const generics, and type definitions in HOL4 don't support trait clauses *) - cassert ((cg_params = [] && trait_clauses = []) || !backend <> HOL4) def.meta "Constant generics and type definitions with trait clauses are not supported yet when generating code for HOL4"; + cassert + ((cg_params = [] && trait_clauses = []) || !backend <> HOL4) + def.meta + "Constant generics and type definitions with trait clauses are not \ + supported yet when generating code for HOL4"; (* Print the generic parameters *) - extract_generic_params def.meta ctx_body fmt type_decl_group ~use_forall def.generics - type_params cg_params trait_clauses; + extract_generic_params def.meta ctx_body fmt type_decl_group ~use_forall + def.generics type_params cg_params trait_clauses; (* Print the "=" if we extract the body*) if extract_body then ( F.pp_print_space fmt (); @@ -1463,9 +1491,16 @@ let extract_type_decl_hol4_opaque (ctx : extraction_ctx) (fmt : F.formatter) (* Retrieve the definition name *) let def_name = ctx_get_local_type def.meta def.def_id ctx in (* Generic parameters are unsupported *) - cassert (def.generics.const_generics = []) def.meta "Constant generics are not supported yet when generating code for HOL4"; + cassert + (def.generics.const_generics = []) + def.meta + "Constant generics are not supported yet when generating code for HOL4"; (* Trait clauses on type definitions are unsupported *) - cassert (def.generics.trait_clauses = []) def.meta "Types with trait clauses are not supported yet when generating code for HOL4"; + cassert + (def.generics.trait_clauses = []) + def.meta + "Types with trait clauses are not supported yet when generating code for \ + HOL4"; (* Types *) (* Count the number of parameters *) let num_params = List.length def.generics.types in @@ -1595,7 +1630,9 @@ let extract_type_decl_coq_arguments (ctx : extraction_ctx) (fmt : F.formatter) (* Generate the instructions *) VariantId.iteri (fun vid (_ : variant) -> - let cons_name = ctx_get_variant decl.meta (TAdtId decl.def_id) vid ctx in + let cons_name = + ctx_get_variant decl.meta (TAdtId decl.def_id) vid ctx + in extract_coq_arguments_instruction ctx fmt cons_name num_params) variants; (* Add breaks to insert new lines between definitions *) @@ -1619,8 +1656,8 @@ let extract_type_decl_record_field_projectors (ctx : extraction_ctx) if is_rec then (* Add the type params *) let ctx, type_params, cg_params, trait_clauses = - ctx_add_generic_params decl.meta decl.llbc_name decl.llbc_generics decl.generics - ctx + ctx_add_generic_params decl.meta decl.llbc_name decl.llbc_generics + decl.generics ctx in let ctx, record_var = ctx_add_var decl.meta "x" (VarId.of_int 0) ctx in let ctx, field_var = ctx_add_var decl.meta "x" (VarId.of_int 1) ctx in @@ -1636,12 +1673,14 @@ let extract_type_decl_record_field_projectors (ctx : extraction_ctx) F.pp_open_hovbox fmt ctx.indent_incr; F.pp_print_string fmt "Definition"; F.pp_print_space fmt (); - let field_name = ctx_get_field decl.meta (TAdtId decl.def_id) field_id ctx in + let field_name = + ctx_get_field decl.meta (TAdtId decl.def_id) field_id ctx + in F.pp_print_string fmt field_name; (* Print the generics *) let as_implicits = true in - extract_generic_params decl.meta ctx fmt TypeDeclId.Set.empty ~as_implicits - decl.generics type_params cg_params trait_clauses; + extract_generic_params decl.meta ctx fmt TypeDeclId.Set.empty + ~as_implicits decl.generics type_params cg_params trait_clauses; (* Print the record parameter *) F.pp_print_space fmt (); F.pp_print_string fmt "("; @@ -1716,10 +1755,14 @@ let extract_type_decl_record_field_projectors (ctx : extraction_ctx) F.pp_open_hvbox fmt 0; (* Inner box for the projector definition *) F.pp_open_hovbox fmt ctx.indent_incr; - let ctx, record_var = ctx_add_var decl.meta "x" (VarId.of_int 0) ctx in + let ctx, record_var = + ctx_add_var decl.meta "x" (VarId.of_int 0) ctx + in F.pp_print_string fmt "Notation"; F.pp_print_space fmt (); - let field_name = ctx_get_field decl.meta (TAdtId decl.def_id) field_id ctx in + let field_name = + ctx_get_field decl.meta (TAdtId decl.def_id) field_id ctx + in F.pp_print_string fmt ("\"" ^ record_var ^ " .(" ^ field_name ^ ")\""); F.pp_print_space fmt (); F.pp_print_string fmt ":="; diff --git a/compiler/FunsAnalysis.ml b/compiler/FunsAnalysis.ml index 9ca35e79..f85f9d1e 100644 --- a/compiler/FunsAnalysis.ml +++ b/compiler/FunsAnalysis.ml @@ -167,8 +167,15 @@ let analyze_module (m : crate) (funs_map : fun_decl FunDeclId.Map.t) (* We need to know if the declaration group contains a global - note that * groups containing globals contain exactly one declaration *) let is_global_decl_body = List.exists (fun f -> f.is_global_decl_body) d in - cassert ((not is_global_decl_body) || List.length d = 1) (List.hd d).meta "This global definition is in a group of mutually recursive definitions"; - cassert ((not !group_has_builtin_info) || List.length d = 1) (List.hd d).meta "This builtin function belongs to a group of mutually recursive definitions"; + cassert + ((not is_global_decl_body) || List.length d = 1) + (List.hd d).meta + "This global definition is in a group of mutually recursive definitions"; + cassert + ((not !group_has_builtin_info) || List.length d = 1) + (List.hd d).meta + "This builtin function belongs to a group of mutually recursive \ + definitions"; (* We ignore on purpose functions that cannot fail and consider they *can* * fail: the result of the analysis is not used yet to adjust the translation * so that the functions which syntactically can't fail don't use an error monad. diff --git a/compiler/Interpreter.ml b/compiler/Interpreter.ml index 034304c7..453ad088 100644 --- a/compiler/Interpreter.ml +++ b/compiler/Interpreter.ml @@ -49,7 +49,8 @@ let compute_contexts (m : crate) : decls_ctx = to compute a normalization map (for the associated types) and that we added it in the context. *) -let normalize_inst_fun_sig (meta : Meta.meta) (ctx : eval_ctx) (sg : inst_fun_sig) : inst_fun_sig = +let normalize_inst_fun_sig (meta : Meta.meta) (ctx : eval_ctx) + (sg : inst_fun_sig) : inst_fun_sig = let { regions_hierarchy = _; trait_type_constraints = _; inputs; output } = sg in @@ -68,8 +69,8 @@ let normalize_inst_fun_sig (meta : Meta.meta) (ctx : eval_ctx) (sg : inst_fun_si clauses (we are not considering a function call, so we don't need to normalize because a trait clause was instantiated with a specific trait ref). *) -let symbolic_instantiate_fun_sig (meta : Meta.meta) (ctx : eval_ctx) (sg : fun_sig) - (regions_hierarchy : region_var_groups) (kind : item_kind) : +let symbolic_instantiate_fun_sig (meta : Meta.meta) (ctx : eval_ctx) + (sg : fun_sig) (regions_hierarchy : region_var_groups) (kind : item_kind) : eval_ctx * inst_fun_sig = let tr_self = match kind with @@ -150,7 +151,9 @@ let symbolic_instantiate_fun_sig (meta : Meta.meta) (ctx : eval_ctx) (sg : fun_s in { regions; types; const_generics; trait_refs } in - let inst_sg = instantiate_fun_sig meta ctx generics tr_self sg regions_hierarchy in + let inst_sg = + instantiate_fun_sig meta ctx generics tr_self sg regions_hierarchy + in (* Compute the normalization maps *) let ctx = AssociatedTypes.ctx_add_norm_trait_types_from_preds meta ctx @@ -203,7 +206,8 @@ let initialize_symbolic_context_for_fun (ctx : decls_ctx) (fdef : fun_decl) : at the same time the normalization map for the associated types. *) let ctx, inst_sg = - symbolic_instantiate_fun_sig fdef.meta ctx fdef.signature regions_hierarchy fdef.kind + symbolic_instantiate_fun_sig fdef.meta ctx fdef.signature regions_hierarchy + fdef.kind in (* Create fresh symbolic values for the inputs *) let input_svs = @@ -236,7 +240,9 @@ let initialize_symbolic_context_for_fun (ctx : decls_ctx) (fdef : fun_decl) : let ctx = ctx_push_uninitialized_var fdef.meta ctx ret_var in (* Push the input variables (initialized with symbolic values) *) let input_values = List.map mk_typed_value_from_symbolic_value input_svs in - let ctx = ctx_push_vars fdef.meta ctx (List.combine input_vars input_values) in + let ctx = + ctx_push_vars fdef.meta ctx (List.combine input_vars input_values) + in (* Push the remaining local variables (initialized with ⊥) *) let ctx = ctx_push_uninitialized_vars fdef.meta ctx local_vars in (* Return *) @@ -281,7 +287,8 @@ let evaluate_function_symbolic_synthesize_backward_from_return (config : config) FunIdMap.find (FRegular fdef.def_id) ctx.fun_ctx.regions_hierarchies in let _, ret_inst_sg = - symbolic_instantiate_fun_sig fdef.meta ctx fdef.signature regions_hierarchy fdef.kind + symbolic_instantiate_fun_sig fdef.meta ctx fdef.signature regions_hierarchy + fdef.kind in let ret_rty = ret_inst_sg.output in (* Move the return value out of the return variable *) @@ -417,9 +424,10 @@ let evaluate_function_symbolic_synthesize_backward_from_return (config : config) | Loop (loop_id', rg_id', LoopSynthInput) -> (* We only allow to end the loop synth input abs for the region group [rg_id] *) - sanity_check ( - if Option.is_some loop_id then loop_id = Some loop_id' - else true) fdef.meta; + sanity_check + (if Option.is_some loop_id then loop_id = Some loop_id' + else true) + fdef.meta; (* Loop abstractions *) let rg_id' = Option.get rg_id' in if rg_id' = back_id && inside_loop then @@ -597,8 +605,8 @@ let evaluate_function_symbolic (synthesize : bool) (ctx : decls_ctx) * the executions can lead to a panic *) if synthesize then Some SA.Panic else None | Unit | Break _ | Continue _ -> - craise - fdef.meta ("evaluate_function_symbolic failed on: " ^ name_to_string ()) + craise fdef.meta + ("evaluate_function_symbolic failed on: " ^ name_to_string ()) in (* Evaluate the function *) @@ -646,12 +654,11 @@ module Test = struct let pop_return_value = true in pop_frame config fdef.meta pop_return_value (fun _ _ -> None) ctx | _ -> - craise - fdef.meta - ("Unit test failed (concrete execution) on: " - ^ Print.Types.name_to_string - (Print.Contexts.decls_ctx_to_fmt_env decls_ctx) - fdef.name) + craise fdef.meta + ("Unit test failed (concrete execution) on: " + ^ Print.Types.name_to_string + (Print.Contexts.decls_ctx_to_fmt_env decls_ctx) + fdef.name) in (* Evaluate the function *) diff --git a/compiler/InterpreterBorrows.ml b/compiler/InterpreterBorrows.ml index c1cf8441..2ccf2d5d 100644 --- a/compiler/InterpreterBorrows.ml +++ b/compiler/InterpreterBorrows.ml @@ -30,8 +30,9 @@ let log = Logging.borrows_log loans. This is used to merge borrows with abstractions, to compute loop fixed points for instance. *) -let end_borrow_get_borrow (meta : Meta.meta) (allowed_abs : AbstractionId.id option) - (allow_inner_loans : bool) (l : BorrowId.id) (ctx : eval_ctx) : +let end_borrow_get_borrow (meta : Meta.meta) + (allowed_abs : AbstractionId.id option) (allow_inner_loans : bool) + (l : BorrowId.id) (ctx : eval_ctx) : ( eval_ctx * (AbstractionId.id option * g_borrow_content) option, priority_borrows_or_abs ) result = @@ -245,17 +246,23 @@ let end_borrow_get_borrow (meta : Meta.meta) (allowed_abs : AbstractionId.id opt give the value back. TODO: this was not the case before, so some sanity checks are not useful anymore. *) -let give_back_value (config : config) (meta : Meta.meta) (bid : BorrowId.id) (nv : typed_value) - (ctx : eval_ctx) : eval_ctx = +let give_back_value (config : config) (meta : Meta.meta) (bid : BorrowId.id) + (nv : typed_value) (ctx : eval_ctx) : eval_ctx = (* Sanity check *) - exec_assert (not (loans_in_value nv)) meta "Can not end a borrow because the value to give back contains bottom"; - exec_assert (not (bottom_in_value ctx.ended_regions nv)) meta "Can not end a borrow because the value to give back contains bottom"; + exec_assert + (not (loans_in_value nv)) + meta "Can not end a borrow because the value to give back contains bottom"; + exec_assert + (not (bottom_in_value ctx.ended_regions nv)) + meta "Can not end a borrow because the value to give back contains bottom"; (* Debug *) log#ldebug (lazy ("give_back_value:\n- bid: " ^ BorrowId.to_string bid ^ "\n- value: " ^ typed_value_to_string ~meta:(Some meta) ctx nv - ^ "\n- context:\n" ^ eval_ctx_to_string ~meta:(Some meta) ctx ^ "\n")); + ^ "\n- context:\n" + ^ eval_ctx_to_string ~meta:(Some meta) ctx + ^ "\n")); (* We use a reference to check that we updated exactly one loan *) let replaced : bool ref = ref false in let set_replaced () = @@ -382,8 +389,8 @@ let give_back_value (config : config) (meta : Meta.meta) (bid : BorrowId.id) (nv let given_back_meta = nv in (* Apply the projection *) let given_back = - apply_proj_borrows meta check_symbolic_no_ended ctx fresh_reborrow - regions ancestors_regions nv borrowed_value_aty + apply_proj_borrows meta check_symbolic_no_ended ctx + fresh_reborrow regions ancestors_regions nv borrowed_value_aty in (* Continue giving back in the child value *) let child = super#visit_typed_avalue opt_abs child in @@ -409,8 +416,8 @@ let give_back_value (config : config) (meta : Meta.meta) (bid : BorrowId.id) (nv * we don't register the fact that we inserted the value somewhere * (i.e., we don't call {!set_replaced}) *) let given_back = - apply_proj_borrows meta check_symbolic_no_ended ctx fresh_reborrow - regions ancestors_regions nv borrowed_value_aty + apply_proj_borrows meta check_symbolic_no_ended ctx + fresh_reborrow regions ancestors_regions nv borrowed_value_aty in (* Continue giving back in the child value *) let child = super#visit_typed_avalue opt_abs child in @@ -440,9 +447,9 @@ let give_back_value (config : config) (meta : Meta.meta) (bid : BorrowId.id) (nv apply_registered_reborrows ctx (** Give back a *modified* symbolic value. *) -let give_back_symbolic_value (_config : config) (meta : Meta.meta) (proj_regions : RegionId.Set.t) - (proj_ty : rty) (sv : symbolic_value) (nsv : symbolic_value) - (ctx : eval_ctx) : eval_ctx = +let give_back_symbolic_value (_config : config) (meta : Meta.meta) + (proj_regions : RegionId.Set.t) (proj_ty : rty) (sv : symbolic_value) + (nsv : symbolic_value) (ctx : eval_ctx) : eval_ctx = (* Sanity checks *) sanity_check (sv.sv_id <> nsv.sv_id && ty_is_rty proj_ty) meta; (* Store the given-back value as a meta-value for synthesis purposes *) @@ -485,8 +492,9 @@ let give_back_symbolic_value (_config : config) (meta : Meta.meta) (proj_regions end abstraction when ending this abstraction. When doing this, we need to convert the {!avalue} to a {!type:value} by introducing the proper symbolic values. *) -let give_back_avalue_to_same_abstraction (_config : config) (meta : Meta.meta) (bid : BorrowId.id) - (nv : typed_avalue) (nsv : typed_value) (ctx : eval_ctx) : eval_ctx = +let give_back_avalue_to_same_abstraction (_config : config) (meta : Meta.meta) + (bid : BorrowId.id) (nv : typed_avalue) (nsv : typed_value) (ctx : eval_ctx) + : eval_ctx = (* We use a reference to check that we updated exactly one loan *) let replaced : bool ref = ref false in let set_replaced () = @@ -588,7 +596,8 @@ let give_back_avalue_to_same_abstraction (_config : config) (meta : Meta.meta) ( we update. TODO: this was not the case before, so some sanity checks are not useful anymore. *) -let give_back_shared _config (meta : Meta.meta) (bid : BorrowId.id) (ctx : eval_ctx) : eval_ctx = +let give_back_shared _config (meta : Meta.meta) (bid : BorrowId.id) + (ctx : eval_ctx) : eval_ctx = (* We use a reference to check that we updated exactly one loan *) let replaced : bool ref = ref false in let set_replaced () = @@ -666,8 +675,8 @@ let give_back_shared _config (meta : Meta.meta) (bid : BorrowId.id) (ctx : eval_ to an environment by inserting a new borrow id in the set of borrows tracked by a shared value, referenced by the [original_bid] argument. *) -let reborrow_shared (meta : Meta.meta) (original_bid : BorrowId.id) (new_bid : BorrowId.id) - (ctx : eval_ctx) : eval_ctx = +let reborrow_shared (meta : Meta.meta) (original_bid : BorrowId.id) + (new_bid : BorrowId.id) (ctx : eval_ctx) : eval_ctx = (* Keep track of changes *) let r = ref false in let set_ref () = @@ -720,7 +729,8 @@ let reborrow_shared (meta : Meta.meta) (original_bid : BorrowId.id) (new_bid : B be expanded (because expanding this symbolic value would require expanding a reference whose region has already ended). *) -let convert_avalue_to_given_back_value (meta : Meta.meta) (av : typed_avalue) : symbolic_value = +let convert_avalue_to_given_back_value (meta : Meta.meta) (av : typed_avalue) : + symbolic_value = mk_fresh_symbolic_value meta av.ty (** Auxiliary function: see {!end_borrow_aux}. @@ -739,8 +749,8 @@ let convert_avalue_to_given_back_value (meta : Meta.meta) (av : typed_avalue) : borrows. This kind of internal reshuffling. should be similar to ending abstractions (it is tantamount to ending *sub*-abstractions). *) -let give_back (config : config) (meta : Meta.meta) (l : BorrowId.id) (bc : g_borrow_content) - (ctx : eval_ctx) : eval_ctx = +let give_back (config : config) (meta : Meta.meta) (l : BorrowId.id) + (bc : g_borrow_content) (ctx : eval_ctx) : eval_ctx = (* Debug *) log#ldebug (lazy @@ -750,7 +760,9 @@ let give_back (config : config) (meta : Meta.meta) (l : BorrowId.id) (bc : g_bor | Abstract bc -> aborrow_content_to_string ~meta:(Some meta) ctx bc in "give_back:\n- bid: " ^ BorrowId.to_string l ^ "\n- content: " ^ bc - ^ "\n- context:\n" ^ eval_ctx_to_string ~meta:(Some meta) ctx ^ "\n")); + ^ "\n- context:\n" + ^ eval_ctx_to_string ~meta:(Some meta) ctx + ^ "\n")); (* This is used for sanity checks *) let sanity_ek = { enter_shared_loans = true; enter_mut_borrows = true; enter_abs = true } @@ -803,8 +815,8 @@ let give_back (config : config) (meta : Meta.meta) (l : BorrowId.id) (bc : g_bor | AEndedSharedBorrow ) -> craise meta "Unreachable" -let check_borrow_disappeared (meta : Meta.meta) (fun_name : string) (l : BorrowId.id) - (ctx0 : eval_ctx) : cm_fun = +let check_borrow_disappeared (meta : Meta.meta) (fun_name : string) + (l : BorrowId.id) (ctx0 : eval_ctx) : cm_fun = let check_disappeared (ctx : eval_ctx) : unit = let _ = match lookup_borrow_opt ek_all l ctx with @@ -814,8 +826,9 @@ let check_borrow_disappeared (meta : Meta.meta) (fun_name : string) (l : BorrowI (lazy (fun_name ^ ": " ^ BorrowId.to_string l ^ ": borrow didn't disappear:\n- original context:\n" - ^ eval_ctx_to_string ~meta:(Some meta) ctx0 ^ "\n\n- new context:\n" - ^ eval_ctx_to_string ~meta:(Some meta) ctx)); + ^ eval_ctx_to_string ~meta:(Some meta) ctx0 + ^ "\n\n- new context:\n" + ^ eval_ctx_to_string ~meta:(Some meta) ctx)); craise meta "Borrow not eliminated" in match lookup_loan_opt meta ek_all l ctx with @@ -825,8 +838,9 @@ let check_borrow_disappeared (meta : Meta.meta) (fun_name : string) (l : BorrowI (lazy (fun_name ^ ": " ^ BorrowId.to_string l ^ ": loan didn't disappear:\n- original context:\n" - ^ eval_ctx_to_string ~meta:(Some meta) ctx0 ^ "\n\n- new context:\n" - ^ eval_ctx_to_string ~meta:(Some meta) ctx)); + ^ eval_ctx_to_string ~meta:(Some meta) ctx0 + ^ "\n\n- new context:\n" + ^ eval_ctx_to_string ~meta:(Some meta) ctx)); craise meta "Loan not eliminated" in unit_to_cm_fun check_disappeared @@ -852,8 +866,9 @@ let check_borrow_disappeared (meta : Meta.meta) (fun_name : string) (l : BorrowI perform anything smart and is trusted, and another function for the book-keeping. *) -let rec end_borrow_aux (config : config) (meta : Meta.meta) (chain : borrow_or_abs_ids) - (allowed_abs : AbstractionId.id option) (l : BorrowId.id) : cm_fun = +let rec end_borrow_aux (config : config) (meta : Meta.meta) + (chain : borrow_or_abs_ids) (allowed_abs : AbstractionId.id option) + (l : BorrowId.id) : cm_fun = fun cf ctx -> (* Check that we don't loop *) let chain0 = chain in @@ -863,7 +878,7 @@ let rec end_borrow_aux (config : config) (meta : Meta.meta) (chain : borrow_or_a log#ldebug (lazy ("end borrow: " ^ BorrowId.to_string l ^ ":\n- original context:\n" - ^ eval_ctx_to_string ~meta:(Some meta) ctx)); + ^ eval_ctx_to_string ~meta:(Some meta) ctx)); (* Utility function for the sanity checks: check that the borrow disappeared * from the context *) @@ -942,8 +957,9 @@ let rec end_borrow_aux (config : config) (meta : Meta.meta) (chain : borrow_or_a (* Compose *) cc cf ctx -and end_borrows_aux (config : config) (meta : Meta.meta) (chain : borrow_or_abs_ids) - (allowed_abs : AbstractionId.id option) (lset : BorrowId.Set.t) : cm_fun = +and end_borrows_aux (config : config) (meta : Meta.meta) + (chain : borrow_or_abs_ids) (allowed_abs : AbstractionId.id option) + (lset : BorrowId.Set.t) : cm_fun = fun cf -> (* This is not necessary, but we prefer to reorder the borrow ids, * so that we actually end from the smallest id to the highest id - just @@ -953,12 +969,13 @@ and end_borrows_aux (config : config) (meta : Meta.meta) (chain : borrow_or_abs_ (fun cf id -> end_borrow_aux config meta chain allowed_abs id cf) cf ids -and end_abstraction_aux (config : config) (meta : Meta.meta) (chain : borrow_or_abs_ids) - (abs_id : AbstractionId.id) : cm_fun = +and end_abstraction_aux (config : config) (meta : Meta.meta) + (chain : borrow_or_abs_ids) (abs_id : AbstractionId.id) : cm_fun = fun cf ctx -> (* Check that we don't loop *) let chain = - add_borrow_or_abs_id_to_chain meta "end_abstraction_aux: " (AbsId abs_id) chain + add_borrow_or_abs_id_to_chain meta "end_abstraction_aux: " (AbsId abs_id) + chain in (* Remember the original context for printing purposes *) let ctx0 = ctx in @@ -966,7 +983,8 @@ and end_abstraction_aux (config : config) (meta : Meta.meta) (chain : borrow_or_ (lazy ("end_abstraction_aux: " ^ AbstractionId.to_string abs_id - ^ "\n- original context:\n" ^ eval_ctx_to_string ~meta:(Some meta) ctx0)); + ^ "\n- original context:\n" + ^ eval_ctx_to_string ~meta:(Some meta) ctx0)); (* Lookup the abstraction - note that if we end a list of abstractions, ending one abstraction may lead to the current abstraction having @@ -984,11 +1002,10 @@ and end_abstraction_aux (config : config) (meta : Meta.meta) (chain : borrow_or_ (* Check that we can end the abstraction *) if abs.can_end then () else - craise - meta - ("Can't end abstraction " - ^ AbstractionId.to_string abs.abs_id - ^ " as it is set as non-endable"); + craise meta + ("Can't end abstraction " + ^ AbstractionId.to_string abs.abs_id + ^ " as it is set as non-endable"); (* End the parent abstractions first *) let cc = end_abstractions_aux config meta chain abs.parents in @@ -1010,7 +1027,8 @@ and end_abstraction_aux (config : config) (meta : Meta.meta) (chain : borrow_or_ (lazy ("end_abstraction_aux: " ^ AbstractionId.to_string abs_id - ^ "\n- context after loans ended:\n" ^ eval_ctx_to_string ~meta:(Some meta) ctx))) + ^ "\n- context after loans ended:\n" + ^ eval_ctx_to_string ~meta:(Some meta) ctx))) in (* End the abstraction itself by redistributing the borrows it contains *) @@ -1030,7 +1048,9 @@ and end_abstraction_aux (config : config) (meta : Meta.meta) (chain : borrow_or_ (* Remove all the references to the id of the current abstraction, and remove * the abstraction itself. * **Rk.**: this is where we synthesize the updated symbolic AST *) - let cc = comp cc (end_abstraction_remove_from_context config meta abs_id) in + let cc = + comp cc (end_abstraction_remove_from_context config meta abs_id) + in (* Debugging *) let cc = @@ -1039,8 +1059,10 @@ and end_abstraction_aux (config : config) (meta : Meta.meta) (chain : borrow_or_ (lazy ("end_abstraction_aux: " ^ AbstractionId.to_string abs_id - ^ "\n- original context:\n" ^ eval_ctx_to_string ~meta:(Some meta) ctx0 - ^ "\n\n- new context:\n" ^ eval_ctx_to_string ~meta:(Some meta) ctx))) + ^ "\n- original context:\n" + ^ eval_ctx_to_string ~meta:(Some meta) ctx0 + ^ "\n\n- new context:\n" + ^ eval_ctx_to_string ~meta:(Some meta) ctx))) in (* Sanity check: ending an abstraction must preserve the invariants *) @@ -1052,8 +1074,8 @@ and end_abstraction_aux (config : config) (meta : Meta.meta) (chain : borrow_or_ (* Apply the continuation *) cc cf ctx -and end_abstractions_aux (config : config) (meta : Meta.meta) (chain : borrow_or_abs_ids) - (abs_ids : AbstractionId.Set.t) : cm_fun = +and end_abstractions_aux (config : config) (meta : Meta.meta) + (chain : borrow_or_abs_ids) (abs_ids : AbstractionId.Set.t) : cm_fun = fun cf -> (* This is not necessary, but we prefer to reorder the abstraction ids, * so that we actually end from the smallest id to the highest id - just @@ -1063,8 +1085,8 @@ and end_abstractions_aux (config : config) (meta : Meta.meta) (chain : borrow_or (fun cf id -> end_abstraction_aux config meta chain id cf) cf abs_ids -and end_abstraction_loans (config : config) (meta : Meta.meta) (chain : borrow_or_abs_ids) - (abs_id : AbstractionId.id) : cm_fun = +and end_abstraction_loans (config : config) (meta : Meta.meta) + (chain : borrow_or_abs_ids) (abs_id : AbstractionId.id) : cm_fun = fun cf ctx -> (* Lookup the abstraction *) let abs = ctx_lookup_abs ctx abs_id in @@ -1091,14 +1113,16 @@ and end_abstraction_loans (config : config) (meta : Meta.meta) (chain : borrow_o | Some (SymbolicValue sv) -> (* There is a proj_loans over a symbolic value: end the proj_borrows * which intersect this proj_loans, then end the proj_loans itself *) - let cc = end_proj_loans_symbolic config meta chain abs_id abs.regions sv in + let cc = + end_proj_loans_symbolic config meta chain abs_id abs.regions sv + in (* Reexplore, looking for loans *) let cc = comp cc (end_abstraction_loans config meta chain abs_id) in (* Continue *) cc cf ctx -and end_abstraction_borrows (config : config) (meta : Meta.meta) (chain : borrow_or_abs_ids) - (abs_id : AbstractionId.id) : cm_fun = +and end_abstraction_borrows (config : config) (meta : Meta.meta) + (chain : borrow_or_abs_ids) (abs_id : AbstractionId.id) : cm_fun = fun cf ctx -> log#ldebug (lazy @@ -1297,9 +1321,9 @@ and end_abstraction_remove_from_context (_config : config) (meta : Meta.meta) intersecting proj_borrows, either in the concrete context or in an abstraction *) -and end_proj_loans_symbolic (config : config) (meta : Meta.meta) (chain : borrow_or_abs_ids) - (abs_id : AbstractionId.id) (regions : RegionId.Set.t) (sv : symbolic_value) - : cm_fun = +and end_proj_loans_symbolic (config : config) (meta : Meta.meta) + (chain : borrow_or_abs_ids) (abs_id : AbstractionId.id) + (regions : RegionId.Set.t) (sv : symbolic_value) : cm_fun = fun cf ctx -> (* Small helpers for sanity checks *) let check ctx = no_aproj_over_symbolic_in_context meta sv ctx in @@ -1310,7 +1334,9 @@ and end_proj_loans_symbolic (config : config) (meta : Meta.meta) (chain : borrow in (* Find the first proj_borrows which intersects the proj_loans *) let explore_shared = true in - match lookup_intersecting_aproj_borrows_opt meta explore_shared regions sv ctx with + match + lookup_intersecting_aproj_borrows_opt meta explore_shared regions sv ctx + with | None -> (* We couldn't find any in the context: it means that the symbolic value * is in the concrete environment (or that we dropped it, in which case @@ -1366,7 +1392,9 @@ and end_proj_loans_symbolic (config : config) (meta : Meta.meta) (chain : borrow let cf_end_internal : cm_fun = fun cf ctx -> (* All the proj_borrows are owned: simply erase them *) - let ctx = remove_intersecting_aproj_borrows_shared meta regions sv ctx in + let ctx = + remove_intersecting_aproj_borrows_shared meta regions sv ctx + in (* End the loan itself *) let ctx = update_aproj_loans_to_ended meta abs_id sv ctx in (* Sanity check *) @@ -1402,9 +1430,11 @@ and end_proj_loans_symbolic (config : config) (meta : Meta.meta) (chain : borrow * replace it with... Maybe we should introduce an ABottomProj? *) let ctx = update_aproj_borrows meta abs_id sv AIgnoredProjBorrows ctx in (* Sanity check: no other occurrence of an intersecting projector of borrows *) - sanity_check ( - Option.is_none - (lookup_intersecting_aproj_borrows_opt meta explore_shared regions sv ctx)) meta ; + sanity_check + (Option.is_none + (lookup_intersecting_aproj_borrows_opt meta explore_shared regions + sv ctx)) + meta; (* End the projector of loans *) let ctx = update_aproj_loans_to_ended meta abs_id sv ctx in (* Sanity check *) @@ -1423,9 +1453,10 @@ and end_proj_loans_symbolic (config : config) (meta : Meta.meta) (chain : borrow (* Continue *) cc cf ctx -let end_borrow config (meta : Meta.meta ) : BorrowId.id -> cm_fun = end_borrow_aux config meta [] None +let end_borrow config (meta : Meta.meta) : BorrowId.id -> cm_fun = + end_borrow_aux config meta [] None -let end_borrows config (meta : Meta.meta ) : BorrowId.Set.t -> cm_fun = +let end_borrows config (meta : Meta.meta) : BorrowId.Set.t -> cm_fun = end_borrows_aux config meta [] None let end_abstraction config meta = end_abstraction_aux config meta [] @@ -1466,7 +1497,9 @@ let promote_shared_loan_to_mut_loan (meta : Meta.meta) (l : BorrowId.id) log#ldebug (lazy ("promote_shared_loan_to_mut_loan:\n- loan: " ^ BorrowId.to_string l - ^ "\n- context:\n" ^ eval_ctx_to_string ~meta:(Some meta) ctx ^ "\n")); + ^ "\n- context:\n" + ^ eval_ctx_to_string ~meta:(Some meta) ctx + ^ "\n")); (* Lookup the shared loan - note that we can't promote a shared loan * in a shared value, but we can do it in a mutably borrowed value. * This is important because we can do: [let y = &two-phase ( *x );] @@ -1479,15 +1512,21 @@ let promote_shared_loan_to_mut_loan (meta : Meta.meta) (l : BorrowId.id) craise meta "Expected a shared loan, found a mut loan" | _, Concrete (VSharedLoan (bids, sv)) -> (* Check that there is only one borrow id (l) and update the loan *) - cassert (BorrowId.Set.mem l bids && BorrowId.Set.cardinal bids = 1) meta "There should only be one borrow id"; + cassert + (BorrowId.Set.mem l bids && BorrowId.Set.cardinal bids = 1) + meta "There should only be one borrow id"; (* We need to check that there aren't any loans in the value: we should have gotten rid of those already, but it is better to do a sanity check. *) sanity_check (not (loans_in_value sv)) meta; (* Check there isn't {!Bottom} (this is actually an invariant *) - cassert (not (bottom_in_value ctx.ended_regions sv)) meta "There shouldn't be a bottom"; + cassert + (not (bottom_in_value ctx.ended_regions sv)) + meta "There shouldn't be a bottom"; (* Check there aren't reserved borrows *) - cassert (not (reserved_in_value sv)) meta "There shouldn't be reserved borrows"; + cassert + (not (reserved_in_value sv)) + meta "There shouldn't be reserved borrows"; (* Update the loan content *) let ctx = update_loan meta ek l (VMutLoan l) ctx in (* Continue *) @@ -1495,18 +1534,17 @@ let promote_shared_loan_to_mut_loan (meta : Meta.meta) (l : BorrowId.id) | _, Abstract _ -> (* I don't think it is possible to have two-phase borrows involving borrows * returned by abstractions. I'm not sure how we could handle that anyway. *) - craise - meta - "Can't promote a shared loan to a mutable loan if the loan is \ - inside an abstraction" + craise meta + "Can't promote a shared loan to a mutable loan if the loan is inside \ + an abstraction" (** Helper function: see {!activate_reserved_mut_borrow}. This function updates a shared borrow to a mutable borrow (and that is all: it doesn't touch the corresponding loan). *) -let replace_reserved_borrow_with_mut_borrow (meta : Meta.meta) (l : BorrowId.id) (cf : m_fun) - (borrowed_value : typed_value) : m_fun = +let replace_reserved_borrow_with_mut_borrow (meta : Meta.meta) (l : BorrowId.id) + (cf : m_fun) (borrowed_value : typed_value) : m_fun = fun ctx -> (* Lookup the reserved borrow - note that we don't go inside borrows/loans: there can't be reserved borrows inside other borrows/loans @@ -1523,17 +1561,16 @@ let replace_reserved_borrow_with_mut_borrow (meta : Meta.meta) (l : BorrowId.id) update_borrow meta ek l (VMutBorrow (l, borrowed_value)) ctx | Abstract _ -> (* This can't happen for sure *) - craise - meta - "Can't promote a shared borrow to a mutable borrow if the borrow \ - is inside an abstraction" + craise meta + "Can't promote a shared borrow to a mutable borrow if the borrow is \ + inside an abstraction" in (* Continue *) cf ctx (** Promote a reserved mut borrow to a mut borrow. *) -let rec promote_reserved_mut_borrow (config : config) (meta : Meta.meta) (l : BorrowId.id) : cm_fun - = +let rec promote_reserved_mut_borrow (config : config) (meta : Meta.meta) + (l : BorrowId.id) : cm_fun = fun cf ctx -> (* Lookup the value *) let ek = @@ -1588,10 +1625,9 @@ let rec promote_reserved_mut_borrow (config : config) (meta : Meta.meta) (l : Bo | _, Abstract _ -> (* I don't think it is possible to have two-phase borrows involving borrows * returned by abstractions. I'm not sure how we could handle that anyway. *) - craise - meta - "Can't activate a reserved mutable borrow referencing a loan inside\n\ - \ an abstraction" + craise meta + "Can't activate a reserved mutable borrow referencing a loan inside\n\ + \ an abstraction" let destructure_abs (meta : Meta.meta) (abs_kind : abs_kind) (can_end : bool) (destructure_shared_values : bool) (ctx : eval_ctx) (abs0 : abs) : abs = @@ -1621,7 +1657,9 @@ let destructure_abs (meta : Meta.meta) (abs_kind : abs_kind) (can_end : bool) match lc with | ASharedLoan (bids, sv, child_av) -> (* We don't support nested borrows for now *) - cassert (not (value_has_borrows ctx sv.value)) meta "Nested borrows are not supported yet"; + cassert + (not (value_has_borrows ctx sv.value)) + meta "Nested borrows are not supported yet"; (* Destructure the shared value *) let avl, sv = if destructure_shared_values then list_values sv else ([], sv) @@ -1648,7 +1686,9 @@ let destructure_abs (meta : Meta.meta) (abs_kind : abs_kind) (can_end : bool) push { value; ty } | AIgnoredMutLoan (opt_bid, child_av) -> (* We don't support nested borrows for now *) - cassert (not (ty_has_borrows ctx.type_ctx.type_infos child_av.ty)) meta "Nested borrows are not supported yet"; + cassert + (not (ty_has_borrows ctx.type_ctx.type_infos child_av.ty)) + meta "Nested borrows are not supported yet"; sanity_check (opt_bid = None) meta; (* Simply explore the child *) list_avalues false push_fail child_av @@ -1659,7 +1699,9 @@ let destructure_abs (meta : Meta.meta) (abs_kind : abs_kind) (can_end : bool) { child = child_av; given_back = _; given_back_meta = _ } | AIgnoredSharedLoan child_av -> (* We don't support nested borrows for now *) - cassert (not (ty_has_borrows ctx.type_ctx.type_infos child_av.ty)) meta "Nested borrows are not supported yet"; + cassert + (not (ty_has_borrows ctx.type_ctx.type_infos child_av.ty)) + meta "Nested borrows are not supported yet"; (* Simply explore the child *) list_avalues false push_fail child_av) | ABorrow bc -> ( @@ -1679,14 +1721,18 @@ let destructure_abs (meta : Meta.meta) (abs_kind : abs_kind) (can_end : bool) push av | AIgnoredMutBorrow (opt_bid, child_av) -> (* We don't support nested borrows for now *) - cassert (not (ty_has_borrows ctx.type_ctx.type_infos child_av.ty)) meta "Nested borrows are not supported yet"; + cassert + (not (ty_has_borrows ctx.type_ctx.type_infos child_av.ty)) + meta "Nested borrows are not supported yet"; sanity_check (opt_bid = None) meta; (* Just explore the child *) list_avalues false push_fail child_av | AEndedIgnoredMutBorrow { child = child_av; given_back = _; given_back_meta = _ } -> (* We don't support nested borrows for now *) - cassert (not (ty_has_borrows ctx.type_ctx.type_infos child_av.ty)) meta "Nested borrows are not supported yet"; + cassert + (not (ty_has_borrows ctx.type_ctx.type_infos child_av.ty)) + meta "Nested borrows are not supported yet"; (* Just explore the child *) list_avalues false push_fail child_av | AProjSharedBorrow asb -> @@ -1725,9 +1771,12 @@ let destructure_abs (meta : Meta.meta) (abs_kind : abs_kind) (can_end : bool) let avl, sv = list_values sv in if destructure_shared_values then ( (* Rem.: the shared value can't contain loans nor borrows *) - cassert (ty_no_regions ty) meta "Nested borrows are not supported yet"; + cassert (ty_no_regions ty) meta + "Nested borrows are not supported yet"; let av : typed_avalue = - sanity_check (not (value_has_loans_or_borrows ctx sv.value)) meta; + sanity_check + (not (value_has_loans_or_borrows ctx sv.value)) + meta; (* We introduce fresh ids for the symbolic values *) let mk_value_with_fresh_sids (v : typed_value) : typed_value = let visitor = @@ -1742,7 +1791,9 @@ let destructure_abs (meta : Meta.meta) (abs_kind : abs_kind) (can_end : bool) in let sv = mk_value_with_fresh_sids sv in (* Create the new avalue *) - let value = ALoan (ASharedLoan (bids, sv, mk_aignored meta ty)) in + let value = + ALoan (ASharedLoan (bids, sv, mk_aignored meta ty)) + in { value; ty } in let avl = List.append [ av ] avl in @@ -1762,16 +1813,16 @@ let destructure_abs (meta : Meta.meta) (abs_kind : abs_kind) (can_end : bool) (* Update *) { abs0 with avalues; kind = abs_kind; can_end } -let abs_is_destructured (meta : Meta.meta) (destructure_shared_values : bool) (ctx : eval_ctx) - (abs : abs) : bool = +let abs_is_destructured (meta : Meta.meta) (destructure_shared_values : bool) + (ctx : eval_ctx) (abs : abs) : bool = let abs' = destructure_abs meta abs.kind abs.can_end destructure_shared_values ctx abs in abs = abs' -let convert_value_to_abstractions (meta : Meta.meta) (abs_kind : abs_kind) (can_end : bool) - (destructure_shared_values : bool) (ctx : eval_ctx) (v : typed_value) : - abs list = +let convert_value_to_abstractions (meta : Meta.meta) (abs_kind : abs_kind) + (can_end : bool) (destructure_shared_values : bool) (ctx : eval_ctx) + (v : typed_value) : abs list = (* Convert the value to a list of avalues *) let absl = ref [] in let push_abs (r_id : RegionId.id) (avalues : typed_avalue list) : unit = @@ -1852,20 +1903,24 @@ let convert_value_to_abstractions (meta : Meta.meta) (abs_kind : abs_kind) (can_ (avl, { v with value = VAdt adt }) | VBorrow bc -> ( let _, ref_ty, kind = ty_as_ref ty in - cassert (ty_no_regions ref_ty) meta "Nested borrows are not supported yet"; + cassert (ty_no_regions ref_ty) meta + "Nested borrows are not supported yet"; (* Sanity check *) sanity_check allow_borrows meta; (* Convert the borrow content *) match bc with | VSharedBorrow bid -> - cassert (ty_no_regions ref_ty) meta "Nested borrows are not supported yet"; + cassert (ty_no_regions ref_ty) meta + "Nested borrows are not supported yet"; let ty = TRef (RFVar r_id, ref_ty, kind) in let value = ABorrow (ASharedBorrow bid) in ([ { value; ty } ], v) | VMutBorrow (bid, bv) -> let r_id = if group then r_id else fresh_region_id () in (* We don't support nested borrows for now *) - cassert (not (value_has_borrows ctx bv.value)) meta "Nested borrows are not supported yet"; + cassert + (not (value_has_borrows ctx bv.value)) + meta "Nested borrows are not supported yet"; (* Create an avalue to push - note that we use [AIgnore] for the inner avalue *) let ty = TRef (RFVar r_id, ref_ty, kind) in let ignored = mk_aignored meta ref_ty in @@ -1884,10 +1939,13 @@ let convert_value_to_abstractions (meta : Meta.meta) (abs_kind : abs_kind) (can_ | VSharedLoan (bids, sv) -> let r_id = if group then r_id else fresh_region_id () in (* We don't support nested borrows for now *) - cassert (not (value_has_borrows ctx sv.value)) meta "Nested borrows are not supported yet"; + cassert + (not (value_has_borrows ctx sv.value)) + meta "Nested borrows are not supported yet"; (* Push the avalue - note that we use [AIgnore] for the inner avalue *) (* For avalues, a loan has the borrow type *) - cassert (ty_no_regions ty) meta "Nested borrows are not supported yet"; + cassert (ty_no_regions ty) meta + "Nested borrows are not supported yet"; let ty = mk_ref_ty (RFVar r_id) ty RShared in let ignored = mk_aignored meta ty in (* Rem.: the shared value might contain loans *) @@ -1905,7 +1963,8 @@ let convert_value_to_abstractions (meta : Meta.meta) (abs_kind : abs_kind) (can_ | VMutLoan bid -> (* Push the avalue - note that we use [AIgnore] for the inner avalue *) (* For avalues, a loan has the borrow type *) - cassert (ty_no_regions ty) meta "Nested borrows are not supported yet"; + cassert (ty_no_regions ty) meta + "Nested borrows are not supported yet"; let ty = mk_ref_ty (RFVar r_id) ty RMut in let ignored = mk_aignored meta ty in let av = ALoan (AMutLoan (bid, ignored)) in @@ -1914,7 +1973,9 @@ let convert_value_to_abstractions (meta : Meta.meta) (abs_kind : abs_kind) (can_ | VSymbolic _ -> (* For now, we force all the symbolic values containing borrows to be eagerly expanded, and we don't support nested borrows *) - cassert (not (value_has_borrows ctx v.value)) meta "Nested borrows are not supported yet"; + cassert + (not (value_has_borrows ctx v.value)) + meta "Nested borrows are not supported yet"; (* Return nothing *) ([], v) in @@ -1955,8 +2016,8 @@ type merge_abstraction_info = { - all the borrows are destructured (for instance, shared loans can't contain shared loans). *) -let compute_merge_abstraction_info (meta : Meta.meta) (ctx : eval_ctx) (abs : abs) : - merge_abstraction_info = +let compute_merge_abstraction_info (meta : Meta.meta) (ctx : eval_ctx) + (abs : abs) : merge_abstraction_info = let loans : loan_id_set ref = ref BorrowId.Set.empty in let borrows : borrow_id_set ref = ref BorrowId.Set.empty in let borrows_loans : borrow_or_loan_id list ref = ref [] in @@ -2068,7 +2129,7 @@ let compute_merge_abstraction_info (meta : Meta.meta) (ctx : eval_ctx) (abs : ab method! visit_symbolic_value _ sv = (* Sanity check: no borrows *) - sanity_check (not (symbolic_value_has_borrows ctx sv)) meta + sanity_check (not (symbolic_value_has_borrows ctx sv)) meta end in @@ -2135,19 +2196,25 @@ type merge_duplicates_funcs = { Merge two abstractions into one, without updating the context. *) -let merge_into_abstraction_aux (meta : Meta.meta) (abs_kind : abs_kind) (can_end : bool) - (merge_funs : merge_duplicates_funcs option) (ctx : eval_ctx) (abs0 : abs) - (abs1 : abs) : abs = +let merge_into_abstraction_aux (meta : Meta.meta) (abs_kind : abs_kind) + (can_end : bool) (merge_funs : merge_duplicates_funcs option) + (ctx : eval_ctx) (abs0 : abs) (abs1 : abs) : abs = log#ldebug (lazy - ("merge_into_abstraction_aux:\n- abs0:\n" ^ abs_to_string meta ctx abs0 - ^ "\n\n- abs1:\n" ^ abs_to_string meta ctx abs1)); + ("merge_into_abstraction_aux:\n- abs0:\n" + ^ abs_to_string meta ctx abs0 + ^ "\n\n- abs1:\n" + ^ abs_to_string meta ctx abs1)); (* Check that the abstractions are destructured *) if !Config.sanity_checks then ( let destructure_shared_values = true in - sanity_check (abs_is_destructured meta destructure_shared_values ctx abs0) meta; - sanity_check (abs_is_destructured meta destructure_shared_values ctx abs1) meta); + sanity_check + (abs_is_destructured meta destructure_shared_values ctx abs0) + meta; + sanity_check + (abs_is_destructured meta destructure_shared_values ctx abs1) + meta); (* Compute the relevant information *) let { @@ -2172,9 +2239,10 @@ let merge_into_abstraction_aux (meta : Meta.meta) (abs_kind : abs_kind) (can_end (* Sanity check: there is no loan/borrows which appears in both abstractions, unless we allow to merge duplicates *) - if merge_funs = None then ( - sanity_check (BorrowId.Set.disjoint borrows0 borrows1) meta; - sanity_check (BorrowId.Set.disjoint loans0 loans1)) meta; + if merge_funs = None then + (sanity_check (BorrowId.Set.disjoint borrows0 borrows1) meta; + sanity_check (BorrowId.Set.disjoint loans0 loans1)) + meta; (* Merge. There are several cases: @@ -2405,10 +2473,13 @@ let merge_into_abstraction_aux (meta : Meta.meta) (abs_kind : abs_kind) (can_end match lc with | ASharedLoan (bids, sv, child) -> let bids = filter_bids bids in - sanity_check (not (BorrowId.Set.is_empty bids)) meta; + sanity_check + (not (BorrowId.Set.is_empty bids)) + meta; sanity_check (is_aignored child.value) meta; - sanity_check ( - not (value_has_loans_or_borrows ctx sv.value)) meta; + sanity_check + (not (value_has_loans_or_borrows ctx sv.value)) + meta; let lc = ASharedLoan (bids, sv, child) in set_loans_as_merged bids; Some { value = ALoan lc; ty } @@ -2487,9 +2558,9 @@ let ctx_merge_regions (ctx : eval_ctx) (rid : RegionId.id) let env = Substitute.env_subst_rids rsubst ctx.env in { ctx with env } -let merge_into_abstraction (meta : Meta.meta) (abs_kind : abs_kind) (can_end : bool) - (merge_funs : merge_duplicates_funcs option) (ctx : eval_ctx) - (abs_id0 : AbstractionId.id) (abs_id1 : AbstractionId.id) : +let merge_into_abstraction (meta : Meta.meta) (abs_kind : abs_kind) + (can_end : bool) (merge_funs : merge_duplicates_funcs option) + (ctx : eval_ctx) (abs_id0 : AbstractionId.id) (abs_id1 : AbstractionId.id) : eval_ctx * AbstractionId.id = (* Lookup the abstractions *) let abs0 = ctx_lookup_abs ctx abs_id0 in diff --git a/compiler/InterpreterBorrows.mli b/compiler/InterpreterBorrows.mli index fbd2cd7a..30b75790 100644 --- a/compiler/InterpreterBorrows.mli +++ b/compiler/InterpreterBorrows.mli @@ -8,7 +8,8 @@ open Cps applies this change to an environment [ctx] by inserting a new borrow id in the set of borrows tracked by a shared value, referenced by the [original_bid] argument. *) -val reborrow_shared : Meta.meta -> BorrowId.id -> BorrowId.id -> eval_ctx -> eval_ctx +val reborrow_shared : + Meta.meta -> BorrowId.id -> BorrowId.id -> eval_ctx -> eval_ctx (** End a borrow identified by its id, while preserving the invariants. @@ -27,10 +28,12 @@ val end_abstraction : config -> Meta.meta -> AbstractionId.id -> cm_fun val end_abstractions : config -> Meta.meta -> AbstractionId.Set.t -> cm_fun (** End a borrow and return the resulting environment, ignoring synthesis *) -val end_borrow_no_synth : config -> Meta.meta -> BorrowId.id -> eval_ctx -> eval_ctx +val end_borrow_no_synth : + config -> Meta.meta -> BorrowId.id -> eval_ctx -> eval_ctx (** End a set of borrows and return the resulting environment, ignoring synthesis *) -val end_borrows_no_synth : config -> Meta.meta -> BorrowId.Set.t -> eval_ctx -> eval_ctx +val end_borrows_no_synth : + config -> Meta.meta -> BorrowId.Set.t -> eval_ctx -> eval_ctx (** End an abstraction and return the resulting environment, ignoring synthesis *) val end_abstraction_no_synth : @@ -91,7 +94,8 @@ val promote_reserved_mut_borrow : config -> Meta.meta -> BorrowId.id -> cm_fun - [ctx] - [abs] *) -val destructure_abs : Meta.meta -> abs_kind -> bool -> bool -> eval_ctx -> abs -> abs +val destructure_abs : + Meta.meta -> abs_kind -> bool -> bool -> eval_ctx -> abs -> abs (** Return [true] if the values in an abstraction are destructured. @@ -232,7 +236,7 @@ type merge_duplicates_funcs = { results from the merge. *) val merge_into_abstraction : - Meta.meta -> + Meta.meta -> abs_kind -> bool -> merge_duplicates_funcs option -> diff --git a/compiler/InterpreterBorrowsCore.ml b/compiler/InterpreterBorrowsCore.ml index 1948c5a6..02ceffb4 100644 --- a/compiler/InterpreterBorrowsCore.ml +++ b/compiler/InterpreterBorrowsCore.ml @@ -72,13 +72,12 @@ let borrow_or_abs_ids_chain_to_string (ids : borrow_or_abs_ids) : string = String.concat " -> " ids (** Add a borrow or abs id to a chain of ids, while checking that we don't loop *) -let add_borrow_or_abs_id_to_chain (meta : Meta.meta) (msg : string) (id : borrow_or_abs_id) - (ids : borrow_or_abs_ids) : borrow_or_abs_ids = +let add_borrow_or_abs_id_to_chain (meta : Meta.meta) (msg : string) + (id : borrow_or_abs_id) (ids : borrow_or_abs_ids) : borrow_or_abs_ids = if List.mem id ids then - craise - meta - (msg ^ "detected a loop in the chain of ids: " - ^ borrow_or_abs_ids_chain_to_string (id :: ids)) + craise meta + (msg ^ "detected a loop in the chain of ids: " + ^ borrow_or_abs_ids_chain_to_string (id :: ids)) else id :: ids (** Helper function. @@ -95,7 +94,8 @@ let add_borrow_or_abs_id_to_chain (meta : Meta.meta) (msg : string) (id : borrow TODO: is there a way of deriving such a comparison? TODO: rename *) -let rec compare_rtys (meta : Meta.meta) (default : bool) (combine : bool -> bool -> bool) +let rec compare_rtys (meta : Meta.meta) (default : bool) + (combine : bool -> bool -> bool) (compare_regions : region -> region -> bool) (ty1 : rty) (ty2 : rty) : bool = let compare = compare_rtys meta default combine compare_regions in @@ -173,8 +173,8 @@ let rec compare_rtys (meta : Meta.meta) (default : bool) (combine : bool -> bool Note that the two abstractions have different views (in terms of regions) of the symbolic value (hence the two region types). *) -let projections_intersect (meta : Meta.meta) (ty1 : rty) (rset1 : RegionId.Set.t) (ty2 : rty) - (rset2 : RegionId.Set.t) : bool = +let projections_intersect (meta : Meta.meta) (ty1 : rty) + (rset1 : RegionId.Set.t) (ty2 : rty) (rset2 : RegionId.Set.t) : bool = let default = false in let combine b1 b2 = b1 || b2 in let compare_regions r1 r2 = @@ -188,8 +188,8 @@ let projections_intersect (meta : Meta.meta) (ty1 : rty) (rset1 : RegionId.Set.t The regions in the types shouldn't be erased (this function will raise an exception otherwise). *) -let projection_contains (meta : Meta.meta) (ty1 : rty) (rset1 : RegionId.Set.t) (ty2 : rty) - (rset2 : RegionId.Set.t) : bool = +let projection_contains (meta : Meta.meta) (ty1 : rty) (rset1 : RegionId.Set.t) + (ty2 : rty) (rset2 : RegionId.Set.t) : bool = let default = true in let combine b1 b2 = b1 && b2 in let compare_regions r1 r2 = @@ -205,8 +205,8 @@ let projection_contains (meta : Meta.meta) (ty1 : rty) (rset1 : RegionId.Set.t) the {!InterpreterUtils.abs_or_var_id} is not necessarily {!constructor:Aeneas.InterpreterUtils.abs_or_var_id.VarId} or {!constructor:Aeneas.InterpreterUtils.abs_or_var_id.DummyVarId}: there can be concrete loans in abstractions (in the shared values). *) -let lookup_loan_opt (meta : Meta.meta) (ek : exploration_kind) (l : BorrowId.id) (ctx : eval_ctx) : - (abs_or_var_id * g_loan_content) option = +let lookup_loan_opt (meta : Meta.meta) (ek : exploration_kind) (l : BorrowId.id) + (ctx : eval_ctx) : (abs_or_var_id * g_loan_content) option = (* We store here whether we are inside an abstraction or a value - note that we * could also track that with the environment, it would probably be more idiomatic * and cleaner *) @@ -301,8 +301,8 @@ let lookup_loan_opt (meta : Meta.meta) (ek : exploration_kind) (l : BorrowId.id) The loan is referred to by a borrow id. Raises an exception if no loan was found. *) -let lookup_loan (meta : Meta.meta) (ek : exploration_kind) (l : BorrowId.id) (ctx : eval_ctx) : - abs_or_var_id * g_loan_content = +let lookup_loan (meta : Meta.meta) (ek : exploration_kind) (l : BorrowId.id) + (ctx : eval_ctx) : abs_or_var_id * g_loan_content = match lookup_loan_opt meta ek l ctx with | None -> craise meta "Unreachable" | Some res -> res @@ -313,8 +313,8 @@ let lookup_loan (meta : Meta.meta) (ek : exploration_kind) (l : BorrowId.id) (ct This is a helper function: it might break invariants. *) -let update_loan (meta : Meta.meta) (ek : exploration_kind) (l : BorrowId.id) (nlc : loan_content) - (ctx : eval_ctx) : eval_ctx = +let update_loan (meta : Meta.meta) (ek : exploration_kind) (l : BorrowId.id) + (nlc : loan_content) (ctx : eval_ctx) : eval_ctx = (* We use a reference to check that we update exactly one loan: when updating * inside values, we check we don't update more than one loan. Then, upon * returning we check that we updated at least once. *) @@ -376,8 +376,8 @@ let update_loan (meta : Meta.meta) (ek : exploration_kind) (l : BorrowId.id) (nl This is a helper function: it might break invariants. *) -let update_aloan (meta : Meta.meta ) (ek : exploration_kind) (l : BorrowId.id) (nlc : aloan_content) - (ctx : eval_ctx) : eval_ctx = +let update_aloan (meta : Meta.meta) (ek : exploration_kind) (l : BorrowId.id) + (nlc : aloan_content) (ctx : eval_ctx) : eval_ctx = (* We use a reference to check that we update exactly one loan: when updating * inside values, we check we don't update more than one loan. Then, upon * returning we check that we updated at least once. *) @@ -482,8 +482,8 @@ let lookup_borrow_opt (ek : exploration_kind) (l : BorrowId.id) (ctx : eval_ctx) Raise an exception if no loan was found *) -let lookup_borrow (meta : Meta.meta) (ek : exploration_kind) (l : BorrowId.id) (ctx : eval_ctx) : - g_borrow_content = +let lookup_borrow (meta : Meta.meta) (ek : exploration_kind) (l : BorrowId.id) + (ctx : eval_ctx) : g_borrow_content = match lookup_borrow_opt ek l ctx with | None -> craise meta "Unreachable" | Some lc -> lc @@ -551,8 +551,8 @@ let update_borrow (meta : Meta.meta) (ek : exploration_kind) (l : BorrowId.id) This is a helper function: it might break invariants. *) -let update_aborrow (meta : Meta.meta) (ek : exploration_kind) (l : BorrowId.id) (nv : avalue) - (ctx : eval_ctx) : eval_ctx = +let update_aborrow (meta : Meta.meta) (ek : exploration_kind) (l : BorrowId.id) + (nv : avalue) (ctx : eval_ctx) : eval_ctx = (* We use a reference to check that we update exactly one borrow: when updating * inside values, we check we don't update more than one borrow. Then, upon * returning we check that we updated at least once. *) @@ -701,9 +701,9 @@ type looked_up_aproj_borrows = This is a helper function. *) -let lookup_intersecting_aproj_borrows_opt (meta : Meta.meta) (lookup_shared : bool) - (regions : RegionId.Set.t) (sv : symbolic_value) (ctx : eval_ctx) : - looked_up_aproj_borrows option = +let lookup_intersecting_aproj_borrows_opt (meta : Meta.meta) + (lookup_shared : bool) (regions : RegionId.Set.t) (sv : symbolic_value) + (ctx : eval_ctx) : looked_up_aproj_borrows option = let found : looked_up_aproj_borrows option ref = ref None in let set_non_shared ((id, ty) : AbstractionId.id * rty) : unit = match !found with @@ -718,8 +718,7 @@ let lookup_intersecting_aproj_borrows_opt (meta : Meta.meta) (lookup_shared : bo in let check_add_proj_borrows (is_shared : bool) abs sv' proj_ty = if - proj_borrows_intersects_proj_loans - meta + proj_borrows_intersects_proj_loans meta (abs.regions, sv', proj_ty) (regions, sv) then @@ -774,10 +773,13 @@ let lookup_intersecting_aproj_borrows_opt (meta : Meta.meta) (lookup_shared : bo Returns the id of the owning abstraction, and the projection type used in this abstraction. *) -let lookup_intersecting_aproj_borrows_not_shared_opt (meta : Meta.meta) (regions : RegionId.Set.t) - (sv : symbolic_value) (ctx : eval_ctx) : (AbstractionId.id * rty) option = +let lookup_intersecting_aproj_borrows_not_shared_opt (meta : Meta.meta) + (regions : RegionId.Set.t) (sv : symbolic_value) (ctx : eval_ctx) : + (AbstractionId.id * rty) option = let lookup_shared = false in - match lookup_intersecting_aproj_borrows_opt meta lookup_shared regions sv ctx with + match + lookup_intersecting_aproj_borrows_opt meta lookup_shared regions sv ctx + with | None -> None | Some (NonSharedProj (abs_id, rty)) -> Some (abs_id, rty) | _ -> craise meta "Unexpected" @@ -787,7 +789,8 @@ let lookup_intersecting_aproj_borrows_not_shared_opt (meta : Meta.meta) (regions This is a helper function: it might break invariants. *) -let update_intersecting_aproj_borrows (meta : Meta.meta) (can_update_shared : bool) +let update_intersecting_aproj_borrows (meta : Meta.meta) + (can_update_shared : bool) (update_shared : AbstractionId.id -> rty -> abstract_shared_borrows) (update_non_shared : AbstractionId.id -> rty -> aproj) (regions : RegionId.Set.t) (sv : symbolic_value) (ctx : eval_ctx) : eval_ctx @@ -795,7 +798,9 @@ let update_intersecting_aproj_borrows (meta : Meta.meta) (can_update_shared : bo (* Small helpers for sanity checks *) let shared = ref None in let add_shared () = - match !shared with None -> shared := Some true | Some b -> sanity_check b meta + match !shared with + | None -> shared := Some true + | Some b -> sanity_check b meta in let set_non_shared () = match !shared with @@ -804,8 +809,7 @@ let update_intersecting_aproj_borrows (meta : Meta.meta) (can_update_shared : bo in let check_proj_borrows is_shared abs sv' proj_ty = if - proj_borrows_intersects_proj_loans - meta + proj_borrows_intersects_proj_loans meta (abs.regions, sv', proj_ty) (regions, sv) then ( @@ -821,7 +825,7 @@ let update_intersecting_aproj_borrows (meta : Meta.meta) (can_update_shared : bo method! visit_abstract_shared_borrows abs asb = (* Sanity check *) - (match !shared with Some b -> sanity_check b meta | _ -> ()); + (match !shared with Some b -> sanity_check b meta | _ -> ()); (* Explore *) if can_update_shared then let abs = Option.get abs in @@ -864,8 +868,9 @@ let update_intersecting_aproj_borrows (meta : Meta.meta) (can_update_shared : bo This is a helper function: it might break invariants. *) -let update_intersecting_aproj_borrows_non_shared (meta : Meta.meta) (regions : RegionId.Set.t) - (sv : symbolic_value) (nv : aproj) (ctx : eval_ctx) : eval_ctx = +let update_intersecting_aproj_borrows_non_shared (meta : Meta.meta) + (regions : RegionId.Set.t) (sv : symbolic_value) (nv : aproj) + (ctx : eval_ctx) : eval_ctx = (* Small helpers *) let can_update_shared = false in let update_shared _ _ = craise meta "Unexpected" in @@ -890,8 +895,9 @@ let update_intersecting_aproj_borrows_non_shared (meta : Meta.meta) (regions : R This is a helper function: it might break invariants. *) -let remove_intersecting_aproj_borrows_shared (meta : Meta.meta) (regions : RegionId.Set.t) - (sv : symbolic_value) (ctx : eval_ctx) : eval_ctx = +let remove_intersecting_aproj_borrows_shared (meta : Meta.meta) + (regions : RegionId.Set.t) (sv : symbolic_value) (ctx : eval_ctx) : eval_ctx + = (* Small helpers *) let can_update_shared = true in let update_shared _ _ = [] in @@ -931,8 +937,8 @@ let remove_intersecting_aproj_borrows_shared (meta : Meta.meta) (regions : Regio Note that the symbolic value at this place is necessarily equal to [sv], which is why we don't give it as parameters. *) -let update_intersecting_aproj_loans (meta : Meta.meta) (proj_regions : RegionId.Set.t) - (proj_ty : rty) (sv : symbolic_value) +let update_intersecting_aproj_loans (meta : Meta.meta) + (proj_regions : RegionId.Set.t) (proj_ty : rty) (sv : symbolic_value) (subst : abs -> (msymbolic_value * aproj) list -> aproj) (ctx : eval_ctx) : eval_ctx = (* *) @@ -960,7 +966,8 @@ let update_intersecting_aproj_loans (meta : Meta.meta) (proj_regions : RegionId. if same_symbolic_id sv sv' then ( sanity_check (sv.sv_ty = sv'.sv_ty) meta; if - projections_intersect meta proj_ty proj_regions sv'.sv_ty abs.regions + projections_intersect meta proj_ty proj_regions sv'.sv_ty + abs.regions then update abs given_back else super#visit_aproj (Some abs) sproj) else super#visit_aproj (Some abs) sproj @@ -983,8 +990,8 @@ let update_intersecting_aproj_loans (meta : Meta.meta) (proj_regions : RegionId. Sanity check: we check that there is exactly one projector which corresponds to the couple (abstraction id, symbolic value). *) -let lookup_aproj_loans (meta : Meta.meta) (abs_id : AbstractionId.id) (sv : symbolic_value) - (ctx : eval_ctx) : (msymbolic_value * aproj) list = +let lookup_aproj_loans (meta : Meta.meta) (abs_id : AbstractionId.id) + (sv : symbolic_value) (ctx : eval_ctx) : (msymbolic_value * aproj) list = (* Small helpers for sanity checks *) let found = ref None in let set_found x = @@ -1028,8 +1035,8 @@ let lookup_aproj_loans (meta : Meta.meta) (abs_id : AbstractionId.id) (sv : symb Sanity check: we check that there is exactly one projector which corresponds to the couple (abstraction id, symbolic value). *) -let update_aproj_loans (meta : Meta.meta) (abs_id : AbstractionId.id) (sv : symbolic_value) - (nproj : aproj) (ctx : eval_ctx) : eval_ctx = +let update_aproj_loans (meta : Meta.meta) (abs_id : AbstractionId.id) + (sv : symbolic_value) (nproj : aproj) (ctx : eval_ctx) : eval_ctx = (* Small helpers for sanity checks *) let found = ref false in let update () = @@ -1077,8 +1084,8 @@ let update_aproj_loans (meta : Meta.meta) (abs_id : AbstractionId.id) (sv : symb TODO: factorize with {!update_aproj_loans}? *) -let update_aproj_borrows (meta : Meta.meta) (abs_id : AbstractionId.id) (sv : symbolic_value) - (nproj : aproj) (ctx : eval_ctx) : eval_ctx = +let update_aproj_borrows (meta : Meta.meta) (abs_id : AbstractionId.id) + (sv : symbolic_value) (nproj : aproj) (ctx : eval_ctx) : eval_ctx = (* Small helpers for sanity checks *) let found = ref false in let update () = @@ -1128,12 +1135,12 @@ let update_aproj_loans_to_ended (meta : Meta.meta) (abs_id : AbstractionId.id) (* Create the new value for the projector *) let nproj = AEndedProjLoans (sv, given_back) in (* Insert it *) - let ctx = update_aproj_loans meta abs_id sv nproj ctx in + let ctx = update_aproj_loans meta abs_id sv nproj ctx in (* Return *) ctx -let no_aproj_over_symbolic_in_context (meta : Meta.meta) (sv : symbolic_value) (ctx : eval_ctx) : - unit = +let no_aproj_over_symbolic_in_context (meta : Meta.meta) (sv : symbolic_value) + (ctx : eval_ctx) : unit = (* The visitor *) let obj = object @@ -1211,8 +1218,8 @@ let get_first_non_ignored_aloan_in_abstraction (meta : Meta.meta) (abs : abs) : (* There are loan projections over symbolic values *) Some (SymbolicValue sv) -let lookup_shared_value_opt (meta : Meta.meta) (ctx : eval_ctx) (bid : BorrowId.id) : - typed_value option = +let lookup_shared_value_opt (meta : Meta.meta) (ctx : eval_ctx) + (bid : BorrowId.id) : typed_value option = match lookup_loan_opt meta ek_all bid ctx with | None -> None | Some (_, lc) -> ( @@ -1221,5 +1228,6 @@ let lookup_shared_value_opt (meta : Meta.meta) (ctx : eval_ctx) (bid : BorrowId. Some sv | _ -> None) -let lookup_shared_value (meta : Meta.meta) (ctx : eval_ctx) (bid : BorrowId.id) : typed_value = +let lookup_shared_value (meta : Meta.meta) (ctx : eval_ctx) (bid : BorrowId.id) + : typed_value = Option.get (lookup_shared_value_opt meta ctx bid) diff --git a/compiler/InterpreterExpansion.ml b/compiler/InterpreterExpansion.ml index a2550e88..3e1aeef2 100644 --- a/compiler/InterpreterExpansion.ml +++ b/compiler/InterpreterExpansion.ml @@ -48,8 +48,8 @@ type proj_kind = LoanProj | BorrowProj Note that 2. and 3. may have a little bit of duplicated code, but hopefully it would make things clearer. *) -let apply_symbolic_expansion_to_target_avalues (config : config) (meta : Meta.meta) - (allow_reborrows : bool) (proj_kind : proj_kind) +let apply_symbolic_expansion_to_target_avalues (config : config) + (meta : Meta.meta) (allow_reborrows : bool) (proj_kind : proj_kind) (original_sv : symbolic_value) (expansion : symbolic_expansion) (ctx : eval_ctx) : eval_ctx = (* Symbolic values contained in the expansion might contain already ended regions *) @@ -123,8 +123,9 @@ let apply_symbolic_expansion_to_target_avalues (config : config) (meta : Meta.me in (* Apply the projector *) let projected_value = - apply_proj_borrows meta check_symbolic_no_ended ctx fresh_reborrow - proj_regions ancestors_regions expansion proj_ty + apply_proj_borrows meta check_symbolic_no_ended ctx + fresh_reborrow proj_regions ancestors_regions expansion + proj_ty in (* Replace *) projected_value.value @@ -150,8 +151,8 @@ let apply_symbolic_expansion_to_avalues (config : config) (meta : Meta.meta) (allow_reborrows : bool) (original_sv : symbolic_value) (expansion : symbolic_expansion) (ctx : eval_ctx) : eval_ctx = let apply_expansion proj_kind ctx = - apply_symbolic_expansion_to_target_avalues config meta allow_reborrows proj_kind - original_sv expansion ctx + apply_symbolic_expansion_to_target_avalues config meta allow_reborrows + proj_kind original_sv expansion ctx in (* First target the loan projectors, then the borrow projectors *) let ctx = apply_expansion LoanProj ctx in @@ -163,8 +164,8 @@ let apply_symbolic_expansion_to_avalues (config : config) (meta : Meta.meta) Simply replace the symbolic values (*not avalues*) in the context with a given value. Will break invariants if not used properly. *) -let replace_symbolic_values (meta : Meta.meta) (at_most_once : bool) (original_sv : symbolic_value) - (nv : value) (ctx : eval_ctx) : eval_ctx = +let replace_symbolic_values (meta : Meta.meta) (at_most_once : bool) + (original_sv : symbolic_value) (nv : value) (ctx : eval_ctx) : eval_ctx = (* Count *) let replaced = ref false in let replace () = @@ -193,7 +194,9 @@ let apply_symbolic_expansion_non_borrow (config : config) (meta : Meta.meta) (* Apply the expansion to non-abstraction values *) let nv = symbolic_expansion_non_borrow_to_value meta original_sv expansion in let at_most_once = false in - let ctx = replace_symbolic_values meta at_most_once original_sv nv.value ctx in + let ctx = + replace_symbolic_values meta at_most_once original_sv nv.value ctx + in (* Apply the expansion to abstraction values *) let allow_reborrows = false in apply_symbolic_expansion_to_avalues config meta allow_reborrows original_sv @@ -209,13 +212,15 @@ let apply_symbolic_expansion_non_borrow (config : config) (meta : Meta.meta) [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 (meta : Meta.meta) (expand_enumerations : bool) - (def_id : TypeDeclId.id) (generics : generic_args) (ctx : eval_ctx) : - symbolic_expansion list = +let compute_expanded_symbolic_non_assumed_adt_value (meta : Meta.meta) + (expand_enumerations : bool) (def_id : TypeDeclId.id) + (generics : generic_args) (ctx : eval_ctx) : symbolic_expansion list = (* Lookup the definition and check if it is an enumeration with several * variants *) let def = ctx_lookup_type_decl ctx def_id in - sanity_check (List.length generics.regions = List.length def.generics.regions) meta; + sanity_check + (List.length generics.regions = List.length def.generics.regions) + meta; (* Retrieve, for every variant, the list of its instantiated field types *) let variants_fields_types = AssociatedTypes.type_decl_get_inst_norm_variants_fields_rtypes meta ctx def @@ -236,8 +241,8 @@ let compute_expanded_symbolic_non_assumed_adt_value (meta : Meta.meta) (expand_e (* Initialize all the expanded values of all the variants *) List.map initialize variants_fields_types -let compute_expanded_symbolic_tuple_value (meta : Meta.meta) (field_types : rty list) : - symbolic_expansion = +let compute_expanded_symbolic_tuple_value (meta : Meta.meta) + (field_types : rty list) : symbolic_expansion = (* Generate the field values *) let field_values = List.map (fun sv_ty -> mk_fresh_symbolic_value meta sv_ty) field_types @@ -246,7 +251,8 @@ let compute_expanded_symbolic_tuple_value (meta : Meta.meta) (field_types : rty let see = SeAdt (variant_id, field_values) in see -let compute_expanded_symbolic_box_value (meta : Meta.meta) (boxed_ty : rty) : symbolic_expansion = +let compute_expanded_symbolic_box_value (meta : Meta.meta) (boxed_ty : rty) : + symbolic_expansion = (* Introduce a fresh symbolic value *) let boxed_value = mk_fresh_symbolic_value meta boxed_ty in let see = SeAdt (None, [ boxed_value ]) in @@ -261,19 +267,19 @@ let compute_expanded_symbolic_box_value (meta : Meta.meta) (boxed_ty : rty) : sy [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 (meta : Meta.meta) (expand_enumerations : bool) - (adt_id : type_id) (generics : generic_args) (ctx : eval_ctx) : - symbolic_expansion list = +let compute_expanded_symbolic_adt_value (meta : Meta.meta) + (expand_enumerations : bool) (adt_id : type_id) (generics : generic_args) + (ctx : eval_ctx) : symbolic_expansion list = match (adt_id, generics.regions, generics.types) with | TAdtId def_id, _, _ -> - compute_expanded_symbolic_non_assumed_adt_value meta expand_enumerations def_id - generics ctx - | TTuple, [], _ -> [ compute_expanded_symbolic_tuple_value meta generics.types ] + compute_expanded_symbolic_non_assumed_adt_value meta expand_enumerations + def_id generics ctx + | TTuple, [], _ -> + [ compute_expanded_symbolic_tuple_value meta generics.types ] | TAssumed TBox, [], [ boxed_ty ] -> [ compute_expanded_symbolic_box_value meta boxed_ty ] | _ -> - craise - meta "compute_expanded_symbolic_adt_value: unexpected combination" + craise meta "compute_expanded_symbolic_adt_value: unexpected combination" let expand_symbolic_value_shared_borrow (config : config) (meta : Meta.meta) (original_sv : symbolic_value) (original_sv_place : SA.mplace option) @@ -380,14 +386,14 @@ let expand_symbolic_value_shared_borrow (config : config) (meta : Meta.meta) let see = SeSharedRef (bids, shared_sv) in let allow_reborrows = true in let ctx = - apply_symbolic_expansion_to_avalues config meta allow_reborrows original_sv see - ctx + apply_symbolic_expansion_to_avalues config meta allow_reborrows original_sv + see ctx in (* Call the continuation *) let expr = cf ctx in (* Update the synthesized program *) - S.synthesize_symbolic_expansion_no_branching meta original_sv original_sv_place see - expr + S.synthesize_symbolic_expansion_no_branching meta original_sv + original_sv_place see expr (** TODO: simplify and merge with the other expansion function *) let expand_symbolic_value_borrow (config : config) (meta : Meta.meta) @@ -407,23 +413,27 @@ let expand_symbolic_value_borrow (config : config) (meta : Meta.meta) let see = SeMutRef (bid, sv) in (* Expand the symbolic values - we simply perform a substitution (and * check that we perform exactly one substitution) *) - let nv = symbolic_expansion_non_shared_borrow_to_value meta original_sv see in + let nv = + symbolic_expansion_non_shared_borrow_to_value meta original_sv see + in let at_most_once = true in - let ctx = replace_symbolic_values meta at_most_once original_sv nv.value ctx in + let ctx = + replace_symbolic_values meta at_most_once original_sv nv.value ctx + in (* Expand the symbolic avalues *) let allow_reborrows = true in let ctx = - apply_symbolic_expansion_to_avalues config meta allow_reborrows original_sv - see ctx + apply_symbolic_expansion_to_avalues config meta allow_reborrows + original_sv see ctx in (* Apply the continuation *) let expr = cf ctx in (* Update the synthesized program *) - S.synthesize_symbolic_expansion_no_branching meta original_sv original_sv_place - see expr + S.synthesize_symbolic_expansion_no_branching meta original_sv + original_sv_place see expr | RShared -> - expand_symbolic_value_shared_borrow config meta original_sv original_sv_place - ref_ty cf ctx + expand_symbolic_value_shared_borrow config meta original_sv + original_sv_place ref_ty cf ctx (** A small helper. @@ -441,8 +451,8 @@ let expand_symbolic_value_borrow (config : config) (meta : Meta.meta) We need this continuation separately (i.e., we can't compose it with the continuations in [see_cf_l]) because we perform a join *before* calling it. *) -let apply_branching_symbolic_expansions_non_borrow (config : config) (meta : Meta.meta) - (sv : symbolic_value) (sv_place : SA.mplace option) +let apply_branching_symbolic_expansions_non_borrow (config : config) + (meta : Meta.meta) (sv : symbolic_value) (sv_place : SA.mplace option) (see_cf_l : (symbolic_expansion option * st_cm_fun) list) (cf_after_join : st_m_fun) : m_fun = fun ctx -> @@ -457,15 +467,19 @@ let apply_branching_symbolic_expansions_non_borrow (config : config) (meta : Met let ctx = match see_opt with | None -> ctx - | Some see -> apply_symbolic_expansion_non_borrow config meta sv see ctx + | Some see -> + apply_symbolic_expansion_non_borrow config meta sv see ctx in (* Debug *) log#ldebug (lazy ("apply_branching_symbolic_expansions_non_borrow: " ^ symbolic_value_to_string ctx0 sv - ^ "\n\n- original context:\n" ^ eval_ctx_to_string ~meta:(Some meta) ctx0 - ^ "\n\n- new context:\n" ^ eval_ctx_to_string ~meta:(Some meta) ctx ^ "\n")); + ^ "\n\n- original context:\n" + ^ eval_ctx_to_string ~meta:(Some meta) ctx0 + ^ "\n\n- new context:\n" + ^ eval_ctx_to_string ~meta:(Some meta) ctx + ^ "\n")); (* Continuation *) cf_br cf_after_join ctx) see_cf_l @@ -484,9 +498,9 @@ let apply_branching_symbolic_expansions_non_borrow (config : config) (meta : Met let seel = List.map fst see_cf_l in S.synthesize_symbolic_expansion meta sv sv_place seel subterms -let expand_symbolic_bool (config : config) (meta : Meta.meta) (sv : symbolic_value) - (sv_place : SA.mplace option) (cf_true : st_cm_fun) (cf_false : st_cm_fun) - (cf_after_join : st_m_fun) : m_fun = +let expand_symbolic_bool (config : config) (meta : Meta.meta) + (sv : symbolic_value) (sv_place : SA.mplace option) (cf_true : st_cm_fun) + (cf_false : st_cm_fun) (cf_after_join : st_m_fun) : m_fun = fun ctx -> (* Compute the expanded value *) let original_sv = sv in @@ -501,8 +515,8 @@ let expand_symbolic_bool (config : config) (meta : Meta.meta) (sv : symbolic_val apply_branching_symbolic_expansions_non_borrow config meta original_sv original_sv_place seel cf_after_join ctx -let expand_symbolic_value_no_branching (config : config) (meta : Meta.meta) (sv : symbolic_value) - (sv_place : SA.mplace option) : cm_fun = +let expand_symbolic_value_no_branching (config : config) (meta : Meta.meta) + (sv : symbolic_value) (sv_place : SA.mplace option) : cm_fun = fun cf ctx -> (* Debug *) log#ldebug @@ -523,8 +537,8 @@ let expand_symbolic_value_no_branching (config : config) (meta : Meta.meta) (sv (* Compute the expanded value *) let allow_branching = false in let seel = - compute_expanded_symbolic_adt_value meta allow_branching adt_id generics - ctx + compute_expanded_symbolic_adt_value meta allow_branching adt_id + generics ctx in (* There should be exacly one branch *) let see = Collections.List.to_cons_nil seel in @@ -539,13 +553,12 @@ let expand_symbolic_value_no_branching (config : config) (meta : Meta.meta) (sv original_sv_place see expr (* Borrows *) | TRef (region, ref_ty, rkind) -> - expand_symbolic_value_borrow config meta original_sv original_sv_place region - ref_ty rkind cf ctx + expand_symbolic_value_borrow config meta original_sv original_sv_place + region ref_ty rkind cf ctx | _ -> - craise - meta - ("expand_symbolic_value_no_branching: unexpected type: " - ^ show_rty rty) + craise meta + ("expand_symbolic_value_no_branching: unexpected type: " + ^ show_rty rty) in (* Debug *) let cc = @@ -554,17 +567,20 @@ let expand_symbolic_value_no_branching (config : config) (meta : Meta.meta) (sv (lazy ("expand_symbolic_value_no_branching: " ^ symbolic_value_to_string ctx0 sv - ^ "\n\n- original context:\n" ^ eval_ctx_to_string ~meta:(Some meta) ctx0 - ^ "\n\n- new context:\n" ^ eval_ctx_to_string ~meta:(Some meta) ctx ^ "\n")); + ^ "\n\n- original context:\n" + ^ eval_ctx_to_string ~meta:(Some meta) ctx0 + ^ "\n\n- new context:\n" + ^ eval_ctx_to_string ~meta:(Some meta) ctx + ^ "\n")); (* Sanity check: the symbolic value has disappeared *) sanity_check (not (symbolic_value_id_in_ctx original_sv.sv_id ctx)) meta) in (* Continue *) cc cf ctx -let expand_symbolic_adt (config : config) (meta : Meta.meta) (sv : symbolic_value) - (sv_place : SA.mplace option) (cf_branches : st_cm_fun) - (cf_after_join : st_m_fun) : m_fun = +let expand_symbolic_adt (config : config) (meta : Meta.meta) + (sv : symbolic_value) (sv_place : SA.mplace option) + (cf_branches : st_cm_fun) (cf_after_join : st_m_fun) : m_fun = fun ctx -> (* Debug *) log#ldebug (lazy ("expand_symbolic_adt:" ^ symbolic_value_to_string ctx sv)); @@ -580,19 +596,19 @@ let expand_symbolic_adt (config : config) (meta : Meta.meta) (sv : symbolic_valu let allow_branching = true in (* Compute the expanded value *) let seel = - compute_expanded_symbolic_adt_value meta allow_branching adt_id generics ctx + compute_expanded_symbolic_adt_value meta allow_branching adt_id generics + ctx in (* Apply *) let seel = List.map (fun see -> (Some see, cf_branches)) seel in apply_branching_symbolic_expansions_non_borrow config meta original_sv original_sv_place seel cf_after_join ctx - | _ -> - craise meta ("expand_symbolic_adt: unexpected type: " ^ show_rty rty) + | _ -> craise meta ("expand_symbolic_adt: unexpected type: " ^ show_rty rty) -let expand_symbolic_int (config : config) (meta : Meta.meta) (sv : symbolic_value) - (sv_place : SA.mplace option) (int_type : integer_type) - (tgts : (scalar_value * st_cm_fun) list) (otherwise : st_cm_fun) - (cf_after_join : st_m_fun) : m_fun = +let expand_symbolic_int (config : config) (meta : Meta.meta) + (sv : symbolic_value) (sv_place : SA.mplace option) + (int_type : integer_type) (tgts : (scalar_value * st_cm_fun) list) + (otherwise : st_cm_fun) (cf_after_join : st_m_fun) : m_fun = (* Sanity check *) sanity_check (sv.sv_ty = TLiteral (TInteger int_type)) meta; (* For all the branches of the switch, we expand the symbolic value @@ -620,7 +636,8 @@ let expand_symbolic_int (config : config) (meta : Meta.meta) (sv : symbolic_valu an enumeration with strictly more than one variant, a slice, etc.) or if we need to expand a recursive type (because this leads to looping). *) -let greedy_expand_symbolics_with_borrows (config : config) (meta : Meta.meta) : cm_fun = +let greedy_expand_symbolics_with_borrows (config : config) (meta : Meta.meta) : + cm_fun = fun cf ctx -> (* The visitor object, to look for symbolic values in the concrete environment *) let obj = @@ -661,31 +678,27 @@ let greedy_expand_symbolics_with_borrows (config : config) (meta : Meta.meta) : (match def.kind with | Struct _ | Enum ([] | [ _ ]) -> () | Enum (_ :: _) -> - craise - meta - ("Attempted to greedily expand a symbolic enumeration \ - with > 1 variants (option \ - [greedy_expand_symbolics_with_borrows] of [config]): " - ^ name_to_string ctx def.name) + craise meta + ("Attempted to greedily expand a symbolic enumeration with > \ + 1 variants (option [greedy_expand_symbolics_with_borrows] \ + of [config]): " + ^ name_to_string ctx def.name) | Opaque -> craise meta "Attempted to greedily expand an opaque type"); (* Also, we need to check if the definition is recursive *) if ctx_type_decl_is_rec ctx def_id then - craise - meta - ("Attempted to greedily expand a recursive definition \ - (option [greedy_expand_symbolics_with_borrows] of \ - [config]): " - ^ name_to_string ctx def.name) + craise meta + ("Attempted to greedily expand a recursive definition (option \ + [greedy_expand_symbolics_with_borrows] of [config]): " + ^ name_to_string ctx def.name) else expand_symbolic_value_no_branching config meta sv None | TAdt ((TTuple | TAssumed TBox), _) | TRef (_, _, _) -> (* Ok *) expand_symbolic_value_no_branching config meta sv None | TAdt (TAssumed (TArray | TSlice | TStr), _) -> (* We can't expand those *) - craise - meta - "Attempted to greedily expand an ADT which can't be expanded " + craise meta + "Attempted to greedily expand an ADT which can't be expanded " | TVar _ | TLiteral _ | TNever | TTraitType _ | TArrow _ | TRawPtr _ -> craise meta "Unreachable" in @@ -695,7 +708,8 @@ let greedy_expand_symbolics_with_borrows (config : config) (meta : Meta.meta) : (* Apply *) expand cf ctx -let greedy_expand_symbolic_values (config : config) (meta : Meta.meta) : cm_fun = +let greedy_expand_symbolic_values (config : config) (meta : Meta.meta) : cm_fun + = fun cf ctx -> if Config.greedy_expand_symbolics_with_borrows then ( log#ldebug (lazy "greedy_expand_symbolic_values"); diff --git a/compiler/InterpreterExpansion.mli b/compiler/InterpreterExpansion.mli index 8b0b386a..2ea27ea6 100644 --- a/compiler/InterpreterExpansion.mli +++ b/compiler/InterpreterExpansion.mli @@ -12,7 +12,12 @@ type proj_kind = LoanProj | BorrowProj This function does *not* update the synthesis. *) val apply_symbolic_expansion_non_borrow : - config -> Meta.meta -> symbolic_value -> symbolic_expansion -> eval_ctx -> eval_ctx + config -> + Meta.meta -> + symbolic_value -> + symbolic_expansion -> + eval_ctx -> + eval_ctx (** Expand a symhbolic value, without branching *) val expand_symbolic_value_no_branching : @@ -32,7 +37,13 @@ val expand_symbolic_value_no_branching : then call it). *) val expand_symbolic_adt : - config -> Meta.meta -> symbolic_value -> SA.mplace option -> st_cm_fun -> st_m_fun -> m_fun + config -> + Meta.meta -> + symbolic_value -> + SA.mplace option -> + st_cm_fun -> + st_m_fun -> + m_fun (** Expand a symbolic boolean. @@ -41,7 +52,7 @@ val expand_symbolic_adt : parameter (here, there are exactly two branches). *) val expand_symbolic_bool : - config -> + config -> Meta.meta -> symbolic_value -> SA.mplace option -> @@ -70,7 +81,7 @@ val expand_symbolic_bool : switch. The continuation is thus for the execution *after* the switch. *) val expand_symbolic_int : - config -> + config -> Meta.meta -> symbolic_value -> SA.mplace option -> diff --git a/compiler/InterpreterExpressions.ml b/compiler/InterpreterExpressions.ml index 7045d886..3d01024b 100644 --- a/compiler/InterpreterExpressions.ml +++ b/compiler/InterpreterExpressions.ml @@ -37,7 +37,8 @@ let expand_primitively_copyable_at_place (config : config) (meta : Meta.meta) | None -> cf ctx | Some sv -> let cc = - expand_symbolic_value_no_branching config meta sv (Some (mk_mplace meta p ctx)) + expand_symbolic_value_no_branching config meta sv + (Some (mk_mplace meta p ctx)) in comp cc expand cf ctx in @@ -49,14 +50,18 @@ let expand_primitively_copyable_at_place (config : config) (meta : Meta.meta) We also check that the value *doesn't contain bottoms or reserved borrows*. *) -let read_place (meta : Meta.meta) (access : access_kind) (p : place) (cf : typed_value -> m_fun) : - m_fun = +let read_place (meta : Meta.meta) (access : access_kind) (p : place) + (cf : typed_value -> m_fun) : m_fun = fun ctx -> let v = read_place meta access p ctx in (* Check that there are no bottoms in the value *) - cassert (not (bottom_in_value ctx.ended_regions v)) meta "There should be no bottoms in the value"; + cassert + (not (bottom_in_value ctx.ended_regions v)) + meta "There should be no bottoms in the value"; (* Check that there are no reserved borrows in the value *) - cassert (not (reserved_in_value v)) meta "There should be no reserved borrows in the value"; + cassert + (not (reserved_in_value v)) + meta "There should be no reserved borrows in the value"; (* Call the continuation *) cf v ctx @@ -80,15 +85,16 @@ let access_rplace_reorganize_and_read (config : config) (meta : Meta.meta) (* Compose *) comp cc read_place cf ctx -let access_rplace_reorganize (config : config) (meta : Meta.meta) (expand_prim_copy : bool) - (access : access_kind) (p : place) : cm_fun = +let access_rplace_reorganize (config : config) (meta : Meta.meta) + (expand_prim_copy : bool) (access : access_kind) (p : place) : cm_fun = fun cf ctx -> access_rplace_reorganize_and_read config meta expand_prim_copy access p (fun _v -> cf) ctx (** Convert an operand constant operand value to a typed value *) -let literal_to_typed_value (meta : Meta.meta) (ty : literal_type) (cv : literal) : typed_value = +let literal_to_typed_value (meta : Meta.meta) (ty : literal_type) (cv : literal) + : typed_value = (* Check the type while converting - we actually need some information * contained in the type *) log#ldebug @@ -118,13 +124,14 @@ let literal_to_typed_value (meta : Meta.meta) (ty : literal_type) (cv : literal) parameter to control this copy ([allow_adt_copy]). Note that here by ADT we mean the user-defined ADTs (not tuples or assumed types). *) -let rec copy_value (meta : Meta.meta) (allow_adt_copy : bool) (config : config) (ctx : eval_ctx) - (v : typed_value) : eval_ctx * typed_value = +let rec copy_value (meta : Meta.meta) (allow_adt_copy : bool) (config : config) + (ctx : eval_ctx) (v : typed_value) : eval_ctx * typed_value = log#ldebug (lazy ("copy_value: " ^ typed_value_to_string ~meta:(Some meta) ctx v - ^ "\n- context:\n" ^ eval_ctx_to_string ~meta:(Some meta) ctx)); + ^ "\n- context:\n" + ^ eval_ctx_to_string ~meta:(Some meta) ctx)); (* Remark: at some point we rewrote this function to use iterators, but then * we reverted the changes: the result was less clear actually. In particular, * the fact that we have exhaustive matches below makes very obvious the cases @@ -137,7 +144,7 @@ let rec copy_value (meta : Meta.meta) (allow_adt_copy : bool) (config : config) | TAdt (TAssumed TBox, _) -> exec_raise meta "Can't copy an assumed value other than Option" | TAdt (TAdtId _, _) as ty -> - sanity_check (allow_adt_copy || ty_is_primitively_copyable ty) meta + sanity_check (allow_adt_copy || ty_is_primitively_copyable ty) meta | TAdt (TTuple, _) -> () (* Ok *) | TAdt ( TAssumed (TSlice | TArray), @@ -147,7 +154,9 @@ let rec copy_value (meta : Meta.meta) (allow_adt_copy : bool) (config : config) const_generics = []; trait_refs = []; } ) -> - exec_assert (ty_is_primitively_copyable ty) meta "The type is not primitively copyable" + exec_assert + (ty_is_primitively_copyable ty) + meta "The type is not primitively copyable" | _ -> exec_raise meta "Unreachable"); let ctx, fields = List.fold_left_map @@ -180,7 +189,9 @@ let rec copy_value (meta : Meta.meta) (allow_adt_copy : bool) (config : config) * Note that in the general case, copy is a trait: copying values * thus requires calling the proper function. Here, we copy values * for very simple types such as integers, shared borrows, etc. *) - cassert (ty_is_primitively_copyable (Substitute.erase_regions sp.sv_ty)) meta "Not primitively copyable"; + cassert + (ty_is_primitively_copyable (Substitute.erase_regions sp.sv_ty)) + meta "Not primitively copyable"; (* If the type is copyable, we simply return the current value. Side * remark: what is important to look at when copying symbolic values * is symbolic expansion. The important subcase is the expansion of shared @@ -225,7 +236,8 @@ let rec copy_value (meta : Meta.meta) (allow_adt_copy : bool) (config : config) what we do in the formalization (because we don't enforce the same constraints as MIR in the formalization). *) -let prepare_eval_operand_reorganize (config : config) (meta : Meta.meta) (op : operand) : cm_fun = +let prepare_eval_operand_reorganize (config : config) (meta : Meta.meta) + (op : operand) : cm_fun = fun cf ctx -> let prepare : cm_fun = fun cf ctx -> @@ -249,14 +261,16 @@ let prepare_eval_operand_reorganize (config : config) (meta : Meta.meta) (op : o prepare cf ctx (** Evaluate an operand, without reorganizing the context before *) -let eval_operand_no_reorganize (config : config) (meta : Meta.meta) (op : operand) - (cf : typed_value -> m_fun) : m_fun = +let eval_operand_no_reorganize (config : config) (meta : Meta.meta) + (op : operand) (cf : typed_value -> m_fun) : m_fun = fun ctx -> (* Debug *) log#ldebug (lazy ("eval_operand_no_reorganize: op: " ^ operand_to_string ctx op - ^ "\n- ctx:\n" ^ eval_ctx_to_string ~meta:(Some meta) ctx ^ "\n")); + ^ "\n- ctx:\n" + ^ eval_ctx_to_string ~meta:(Some meta) ctx + ^ "\n")); (* Evaluate *) match op with | Constant cv -> ( @@ -330,11 +344,14 @@ let eval_operand_no_reorganize (config : config) (meta : Meta.meta) (op : operan let copy cf v : m_fun = fun ctx -> (* Sanity checks *) - exec_assert (not (bottom_in_value ctx.ended_regions v)) meta "Can not copy a value containing bottom"; - sanity_check ( - Option.is_none - (find_first_primitively_copyable_sv_with_borrows - ctx.type_ctx.type_infos v)) meta; + exec_assert + (not (bottom_in_value ctx.ended_regions v)) + meta "Can not copy a value containing bottom"; + sanity_check + (Option.is_none + (find_first_primitively_copyable_sv_with_borrows + ctx.type_ctx.type_infos v)) + meta; (* Actually perform the copy *) let allow_adt_copy = false in let ctx, v = copy_value meta allow_adt_copy config ctx v in @@ -351,7 +368,9 @@ let eval_operand_no_reorganize (config : config) (meta : Meta.meta) (op : operan let move cf v : m_fun = fun ctx -> (* Check that there are no bottoms in the value we are about to move *) - exec_assert (not (bottom_in_value ctx.ended_regions v)) meta "There should be no bottoms in the value we are about to move"; + exec_assert + (not (bottom_in_value ctx.ended_regions v)) + meta "There should be no bottoms in the value we are about to move"; let bottom : typed_value = { value = VBottom; ty = v.ty } in let ctx = write_place meta access p bottom ctx in cf v ctx @@ -359,14 +378,15 @@ let eval_operand_no_reorganize (config : config) (meta : Meta.meta) (op : operan (* Compose and apply *) comp cc move cf ctx -let eval_operand (config : config) (meta : Meta.meta) (op : operand) (cf : typed_value -> m_fun) : - m_fun = +let eval_operand (config : config) (meta : Meta.meta) (op : operand) + (cf : typed_value -> m_fun) : m_fun = fun ctx -> (* Debug *) log#ldebug (lazy ("eval_operand: op: " ^ operand_to_string ctx op ^ "\n- ctx:\n" - ^ eval_ctx_to_string ~meta:(Some meta) ctx ^ "\n")); + ^ eval_ctx_to_string ~meta:(Some meta) ctx + ^ "\n")); (* We reorganize the context, then evaluate the operand *) comp (prepare_eval_operand_reorganize config meta op) @@ -377,8 +397,8 @@ let eval_operand (config : config) (meta : Meta.meta) (op : operand) (cf : typed See [prepare_eval_operand_reorganize]. *) -let prepare_eval_operands_reorganize (config : config) (meta : Meta.meta) (ops : operand list) : - cm_fun = +let prepare_eval_operands_reorganize (config : config) (meta : Meta.meta) + (ops : operand list) : cm_fun = fold_left_apply_continuation (prepare_eval_operand_reorganize config meta) ops (** Evaluate several operands. *) @@ -389,23 +409,23 @@ let eval_operands (config : config) (meta : Meta.meta) (ops : operand list) let prepare = prepare_eval_operands_reorganize config meta ops in (* Evaluate the operands *) let eval = - fold_left_list_apply_continuation (eval_operand_no_reorganize config meta) ops + fold_left_list_apply_continuation + (eval_operand_no_reorganize config meta) + ops in (* Compose and apply *) comp prepare eval cf ctx -let eval_two_operands (config : config) (meta : Meta.meta) (op1 : operand) (op2 : operand) - (cf : typed_value * typed_value -> m_fun) : m_fun = +let eval_two_operands (config : config) (meta : Meta.meta) (op1 : operand) + (op2 : operand) (cf : typed_value * typed_value -> m_fun) : m_fun = let eval_op = eval_operands config meta [ op1; op2 ] in let use_res cf res = - match res with - | [ v1; v2 ] -> cf (v1, v2) - | _ -> craise meta "Unreachable" + match res with [ v1; v2 ] -> cf (v1, v2) | _ -> craise meta "Unreachable" in comp eval_op use_res cf -let eval_unary_op_concrete (config : config) (meta : Meta.meta) (unop : unop) (op : operand) - (cf : (typed_value, eval_error) result -> m_fun) : m_fun = +let eval_unary_op_concrete (config : config) (meta : Meta.meta) (unop : unop) + (op : operand) (cf : (typed_value, eval_error) result -> m_fun) : m_fun = (* Evaluate the operand *) let eval_op = eval_operand config meta op in (* Apply the unop *) @@ -452,8 +472,8 @@ let eval_unary_op_concrete (config : config) (meta : Meta.meta) (unop : unop) (o in comp eval_op apply cf -let eval_unary_op_symbolic (config : config) (meta : Meta.meta) (unop : unop) (op : operand) - (cf : (typed_value, eval_error) result -> m_fun) : m_fun = +let eval_unary_op_symbolic (config : config) (meta : Meta.meta) (unop : unop) + (op : operand) (cf : (typed_value, eval_error) result -> m_fun) : m_fun = fun ctx -> (* Evaluate the operand *) let eval_op = eval_operand config meta op in @@ -479,8 +499,8 @@ let eval_unary_op_symbolic (config : config) (meta : Meta.meta) (unop : unop) (o (* Compose and apply *) comp eval_op apply cf ctx -let eval_unary_op (config : config) (meta : Meta.meta) (unop : unop) (op : operand) - (cf : (typed_value, eval_error) result -> m_fun) : m_fun = +let eval_unary_op (config : config) (meta : Meta.meta) (unop : unop) + (op : operand) (cf : (typed_value, eval_error) result -> m_fun) : m_fun = match config.mode with | ConcreteMode -> eval_unary_op_concrete config meta unop op cf | SymbolicMode -> eval_unary_op_symbolic config meta unop op cf @@ -488,15 +508,17 @@ let eval_unary_op (config : config) (meta : Meta.meta) (unop : unop) (op : opera (** Small helper for [eval_binary_op_concrete]: computes the result of applying the binop *after* the operands have been successfully evaluated *) -let eval_binary_op_concrete_compute (meta : Meta.meta) (binop : binop) (v1 : typed_value) - (v2 : typed_value) : (typed_value, eval_error) result = +let eval_binary_op_concrete_compute (meta : Meta.meta) (binop : binop) + (v1 : typed_value) (v2 : typed_value) : (typed_value, eval_error) result = (* Equality check binops (Eq, Ne) accept values from a wide variety of types. * The remaining binops only operate on scalars. *) if binop = Eq || binop = Ne then ( (* Equality operations *) exec_assert (v1.ty = v2.ty) meta "TODO: error message"; (* Equality/inequality check is primitive only for a subset of types *) - exec_assert (ty_is_primitively_copyable v1.ty) meta "Type is not primitively copyable"; + exec_assert + (ty_is_primitively_copyable v1.ty) + meta "Type is not primitively copyable"; let b = v1 = v2 in Ok { value = VLiteral (VBool b); ty = TLiteral TBool }) else @@ -558,8 +580,9 @@ let eval_binary_op_concrete_compute (meta : Meta.meta) (binop : binop) (v1 : typ | Ne | Eq -> craise meta "Unreachable") | _ -> craise meta "Invalid inputs for binop" -let eval_binary_op_concrete (config : config) (meta : Meta.meta) (binop : binop) (op1 : operand) - (op2 : operand) (cf : (typed_value, eval_error) result -> m_fun) : m_fun = +let eval_binary_op_concrete (config : config) (meta : Meta.meta) (binop : binop) + (op1 : operand) (op2 : operand) + (cf : (typed_value, eval_error) result -> m_fun) : m_fun = (* Evaluate the operands *) let eval_ops = eval_two_operands config meta op1 op2 in (* Compute the result of the binop *) @@ -570,8 +593,9 @@ let eval_binary_op_concrete (config : config) (meta : Meta.meta) (binop : binop) (* Compose and apply *) comp eval_ops compute cf -let eval_binary_op_symbolic (config : config) (meta : Meta.meta) (binop : binop) (op1 : operand) - (op2 : operand) (cf : (typed_value, eval_error) result -> m_fun) : m_fun = +let eval_binary_op_symbolic (config : config) (meta : Meta.meta) (binop : binop) + (op1 : operand) (op2 : operand) + (cf : (typed_value, eval_error) result -> m_fun) : m_fun = fun ctx -> (* Evaluate the operands *) let eval_ops = eval_two_operands config meta op1 op2 in @@ -585,7 +609,9 @@ let eval_binary_op_symbolic (config : config) (meta : Meta.meta) (binop : binop) (* Equality operations *) sanity_check (v1.ty = v2.ty) meta; (* Equality/inequality check is primitive only for a subset of types *) - exec_assert (ty_is_primitively_copyable v1.ty) meta "The type is not primitively copyable"; + exec_assert + (ty_is_primitively_copyable v1.ty) + meta "The type is not primitively copyable"; TLiteral TBool) else (* Other operations: input types are integers *) @@ -617,14 +643,15 @@ let eval_binary_op_symbolic (config : config) (meta : Meta.meta) (binop : binop) (* Compose and apply *) comp eval_ops compute cf ctx -let eval_binary_op (config : config) (meta : Meta.meta) (binop : binop) (op1 : operand) - (op2 : operand) (cf : (typed_value, eval_error) result -> m_fun) : m_fun = +let eval_binary_op (config : config) (meta : Meta.meta) (binop : binop) + (op1 : operand) (op2 : operand) + (cf : (typed_value, eval_error) result -> m_fun) : m_fun = match config.mode with | ConcreteMode -> eval_binary_op_concrete config meta binop op1 op2 cf | SymbolicMode -> eval_binary_op_symbolic config meta binop op1 op2 cf -let eval_rvalue_ref (config : config) (meta : Meta.meta) (p : place) (bkind : borrow_kind) - (cf : typed_value -> m_fun) : m_fun = +let eval_rvalue_ref (config : config) (meta : Meta.meta) (p : place) + (bkind : borrow_kind) (cf : typed_value -> m_fun) : m_fun = fun ctx -> match bkind with | BShared | BTwoPhaseMut | BShallow -> @@ -715,8 +742,9 @@ let eval_rvalue_ref (config : config) (meta : Meta.meta) (p : place) (bkind : bo (* Compose and apply *) comp prepare eval cf ctx -let eval_rvalue_aggregate (config : config) (meta : Meta.meta) (aggregate_kind : aggregate_kind) - (ops : operand list) (cf : typed_value -> m_fun) : m_fun = +let eval_rvalue_aggregate (config : config) (meta : Meta.meta) + (aggregate_kind : aggregate_kind) (ops : operand list) + (cf : typed_value -> m_fun) : m_fun = (* Evaluate the operands *) let eval_ops = eval_operands config meta ops in (* Compute the value *) @@ -737,16 +765,18 @@ let eval_rvalue_aggregate (config : config) (meta : Meta.meta) (aggregate_kind : | TAdtId def_id -> (* Sanity checks *) let type_decl = ctx_lookup_type_decl ctx def_id in - sanity_check ( - List.length type_decl.generics.regions - = List.length generics.regions) meta; + sanity_check + (List.length type_decl.generics.regions + = List.length generics.regions) + meta; let expected_field_types = AssociatedTypes.ctx_adt_get_inst_norm_field_etypes meta ctx def_id opt_variant_id generics in - sanity_check ( - expected_field_types - = List.map (fun (v : typed_value) -> v.ty) values) meta; + sanity_check + (expected_field_types + = List.map (fun (v : typed_value) -> v.ty) values) + meta; (* Construct the value *) let av : adt_value = { variant_id = opt_variant_id; field_values = values } @@ -758,7 +788,9 @@ let eval_rvalue_aggregate (config : config) (meta : Meta.meta) (aggregate_kind : | TAssumed _ -> craise meta "Unreachable") | AggregatedArray (ety, cg) -> ( (* Sanity check: all the values have the proper type *) - sanity_check (List.for_all (fun (v : typed_value) -> v.ty = ety) values) meta; + sanity_check + (List.for_all (fun (v : typed_value) -> v.ty = ety) values) + meta; (* Sanity check: the number of values is consistent with the length *) let len = (literal_as_scalar (const_generic_as_literal cg)).value in sanity_check (len = Z.of_int (List.length values)) meta; @@ -782,8 +814,8 @@ let eval_rvalue_aggregate (config : config) (meta : Meta.meta) (aggregate_kind : (* Compose and apply *) comp eval_ops compute cf -let eval_rvalue_not_global (config : config) (meta : Meta.meta) (rvalue : rvalue) - (cf : (typed_value, eval_error) result -> m_fun) : m_fun = +let eval_rvalue_not_global (config : config) (meta : Meta.meta) + (rvalue : rvalue) (cf : (typed_value, eval_error) result -> m_fun) : m_fun = fun ctx -> log#ldebug (lazy "eval_rvalue"); (* Small helpers *) @@ -797,14 +829,14 @@ let eval_rvalue_not_global (config : config) (meta : Meta.meta) (rvalue : rvalue | Use op -> comp_wrap (eval_operand config meta op) ctx | RvRef (p, bkind) -> comp_wrap (eval_rvalue_ref config meta p bkind) ctx | UnaryOp (unop, op) -> eval_unary_op config meta unop op cf ctx - | BinaryOp (binop, op1, op2) -> eval_binary_op config meta binop op1 op2 cf ctx + | BinaryOp (binop, op1, op2) -> + eval_binary_op config meta binop op1 op2 cf ctx | Aggregate (aggregate_kind, ops) -> comp_wrap (eval_rvalue_aggregate config meta aggregate_kind ops) ctx | Discriminant _ -> - craise - meta - "Unreachable: discriminant reads should have been eliminated from \ - the AST" + craise meta + "Unreachable: discriminant reads should have been eliminated from the \ + AST" | Global _ -> craise meta "Unreachable" let eval_fake_read (config : config) (meta : Meta.meta) (p : place) : cm_fun = @@ -815,7 +847,9 @@ let eval_fake_read (config : config) (meta : Meta.meta) (p : place) : cm_fun = in let cf_continue cf v : m_fun = fun ctx -> - cassert (not (bottom_in_value ctx.ended_regions v)) meta "Fake read: the value contains bottom"; + cassert + (not (bottom_in_value ctx.ended_regions v)) + meta "Fake read: the value contains bottom"; cf ctx in comp cf_prepare cf_continue cf ctx diff --git a/compiler/InterpreterExpressions.mli b/compiler/InterpreterExpressions.mli index 76627c40..0fb12180 100644 --- a/compiler/InterpreterExpressions.mli +++ b/compiler/InterpreterExpressions.mli @@ -12,7 +12,8 @@ open InterpreterPaths This function doesn't reorganize the context to make sure we can read the place. If needs be, you should call {!InterpreterPaths.update_ctx_along_read_place} first. *) -val read_place : Meta.meta -> access_kind -> place -> (typed_value -> m_fun) -> m_fun +val read_place : + Meta.meta -> access_kind -> place -> (typed_value -> m_fun) -> m_fun (** Auxiliary function. @@ -31,7 +32,13 @@ val read_place : Meta.meta -> access_kind -> place -> (typed_value -> m_fun) -> primitively copyable and contain borrows. *) val access_rplace_reorganize_and_read : - config -> Meta.meta -> bool -> access_kind -> place -> (typed_value -> m_fun) -> m_fun + config -> + Meta.meta -> + bool -> + access_kind -> + place -> + (typed_value -> m_fun) -> + m_fun (** Evaluate an operand. @@ -42,7 +49,8 @@ val access_rplace_reorganize_and_read : of the environment, before evaluating all the operands at once. Use {!eval_operands} instead. *) -val eval_operand : config -> Meta.meta -> operand -> (typed_value -> m_fun) -> m_fun +val eval_operand : + config -> Meta.meta -> operand -> (typed_value -> m_fun) -> m_fun (** Evaluate several operands at once. *) val eval_operands : @@ -56,7 +64,11 @@ val eval_operands : reads should have been eliminated from the AST. *) val eval_rvalue_not_global : - config -> Meta.meta -> rvalue -> ((typed_value, eval_error) result -> m_fun) -> m_fun + config -> + Meta.meta -> + rvalue -> + ((typed_value, eval_error) result -> m_fun) -> + m_fun (** Evaluate a fake read (update the context so that we can read a place) *) val eval_fake_read : config -> Meta.meta -> place -> cm_fun diff --git a/compiler/InterpreterLoops.ml b/compiler/InterpreterLoops.ml index 89015f71..d369aef9 100644 --- a/compiler/InterpreterLoops.ml +++ b/compiler/InterpreterLoops.ml @@ -15,7 +15,8 @@ open Errors let log = Logging.loops_log (** Evaluate a loop in concrete mode *) -let eval_loop_concrete (meta : Meta.meta) (eval_loop_body : st_cm_fun) : st_cm_fun = +let eval_loop_concrete (meta : Meta.meta) (eval_loop_body : st_cm_fun) : + st_cm_fun = fun cf ctx -> (* We need a loop id for the [LoopReturn]. In practice it won't be used (it is useful only for the symbolic execution *) @@ -68,7 +69,10 @@ let eval_loop_symbolic (config : config) (meta : meta) fun cf ctx -> (* Debug *) log#ldebug - (lazy ("eval_loop_symbolic:\nContext:\n" ^ eval_ctx_to_string ~meta:(Some meta) ctx ^ "\n\n")); + (lazy + ("eval_loop_symbolic:\nContext:\n" + ^ eval_ctx_to_string ~meta:(Some meta) ctx + ^ "\n\n")); (* Generate a fresh loop id *) let loop_id = fresh_loop_id () in @@ -81,11 +85,15 @@ let eval_loop_symbolic (config : config) (meta : meta) (* Debug *) log#ldebug (lazy - ("eval_loop_symbolic:\nInitial context:\n" ^ eval_ctx_to_string ~meta:(Some meta) ctx - ^ "\n\nFixed point:\n" ^ eval_ctx_to_string ~meta:(Some meta) fp_ctx)); + ("eval_loop_symbolic:\nInitial context:\n" + ^ eval_ctx_to_string ~meta:(Some meta) ctx + ^ "\n\nFixed point:\n" + ^ eval_ctx_to_string ~meta:(Some meta) fp_ctx)); (* Compute the loop input parameters *) - let fresh_sids, input_svalues = compute_fp_ctx_symbolic_values meta ctx fp_ctx in + let fresh_sids, input_svalues = + compute_fp_ctx_symbolic_values meta ctx fp_ctx + in let fp_input_svalues = List.map (fun sv -> sv.sv_id) input_svalues in (* Synthesize the end of the function - we simply match the context at the @@ -122,11 +130,13 @@ let eval_loop_symbolic (config : config) (meta : meta) (lazy ("eval_loop_symbolic: about to match the fixed-point context with the \ original context:\n\ - - src ctx (fixed-point ctx)" ^ eval_ctx_to_string ~meta:(Some meta) fp_ctx - ^ "\n\n-tgt ctx (original context):\n" ^ eval_ctx_to_string ~meta:(Some meta) ctx)); + - src ctx (fixed-point ctx)" + ^ eval_ctx_to_string ~meta:(Some meta) fp_ctx + ^ "\n\n-tgt ctx (original context):\n" + ^ eval_ctx_to_string ~meta:(Some meta) ctx)); let end_expr : SymbolicAst.expression option = - match_ctx_with_target config meta loop_id true fp_bl_corresp fp_input_svalues - fixed_ids fp_ctx cf ctx + match_ctx_with_target config meta loop_id true fp_bl_corresp + fp_input_svalues fixed_ids fp_ctx cf ctx in log#ldebug (lazy @@ -155,8 +165,10 @@ let eval_loop_symbolic (config : config) (meta : meta) (lazy ("eval_loop_symbolic: about to match the fixed-point context \ with the context at a continue:\n\ - - src ctx (fixed-point ctx)" ^ eval_ctx_to_string ~meta:(Some meta) fp_ctx - ^ "\n\n-tgt ctx (ctx at continue):\n" ^ eval_ctx_to_string ~meta:(Some meta) ctx)); + - src ctx (fixed-point ctx)" + ^ eval_ctx_to_string ~meta:(Some meta) fp_ctx + ^ "\n\n-tgt ctx (ctx at continue):\n" + ^ eval_ctx_to_string ~meta:(Some meta) ctx)); let cc = match_ctx_with_target config meta loop_id false fp_bl_corresp fp_input_svalues fixed_ids fp_ctx diff --git a/compiler/InterpreterLoopsCore.ml b/compiler/InterpreterLoopsCore.ml index 2de5aed0..660e542d 100644 --- a/compiler/InterpreterLoopsCore.ml +++ b/compiler/InterpreterLoopsCore.ml @@ -261,6 +261,7 @@ module type Matcher = sig Rem.: this function raises exceptions of type {!Aeneas.InterpreterLoopsCore.ValueMatchFailure}. *) val meta : Meta.meta + val match_typed_values : eval_ctx -> eval_ctx -> typed_value -> typed_value -> typed_value @@ -348,6 +349,7 @@ module type MatchJoinState = sig (** The abstractions introduced when performing the matches *) val nabs : abs list ref + val meta : Meta.meta end @@ -356,8 +358,8 @@ end Returns: (fixed, new abs, new dummies) *) -let ctx_split_fixed_new (meta : Meta.meta) (fixed_ids : ids_sets) (ctx : eval_ctx) : - env * abs list * typed_value list = +let ctx_split_fixed_new (meta : Meta.meta) (fixed_ids : ids_sets) + (ctx : eval_ctx) : env * abs list * typed_value list = let is_fresh_did (id : DummyVarId.id) : bool = not (DummyVarId.Set.mem id fixed_ids.dids) in diff --git a/compiler/InterpreterLoopsFixedPoint.ml b/compiler/InterpreterLoopsFixedPoint.ml index f5bd4a35..7ddf55c1 100644 --- a/compiler/InterpreterLoopsFixedPoint.ml +++ b/compiler/InterpreterLoopsFixedPoint.ml @@ -121,8 +121,8 @@ let cleanup_fresh_values (fixed_ids : ids_sets) : cm_fun = - also end the borrows which appear in fresh anonymous values and don't contain loans - end the fresh region abstractions which can be ended (no loans) *) -let cleanup_fresh_values_and_abs (config : config) (meta : Meta.meta) (fixed_ids : ids_sets) : - cm_fun = +let cleanup_fresh_values_and_abs (config : config) (meta : Meta.meta) + (fixed_ids : ids_sets) : cm_fun = fun cf ctx -> comp (end_useless_fresh_borrows_and_abs config meta fixed_ids) @@ -136,8 +136,8 @@ let cleanup_fresh_values_and_abs (config : config) (meta : Meta.meta) (fixed_ids called typically after we merge abstractions together (see {!collapse_ctx} for instance). *) -let reorder_loans_borrows_in_fresh_abs (meta : Meta.meta) (old_abs_ids : AbstractionId.Set.t) - (ctx : eval_ctx) : eval_ctx = +let reorder_loans_borrows_in_fresh_abs (meta : Meta.meta) + (old_abs_ids : AbstractionId.Set.t) (ctx : eval_ctx) : eval_ctx = let reorder_in_fresh_abs (abs : abs) : abs = (* Split between the loans and borrows *) let is_borrow (av : typed_avalue) : bool = @@ -187,7 +187,8 @@ let reorder_loans_borrows_in_fresh_abs (meta : Meta.meta) (old_abs_ids : Abstrac { ctx with env } -let prepare_ashared_loans (meta : Meta.meta) (loop_id : LoopId.id option) : cm_fun = +let prepare_ashared_loans (meta : Meta.meta) (loop_id : LoopId.id option) : + cm_fun = fun cf ctx0 -> let ctx = ctx0 in (* Compute the set of borrows which appear in the abstractions, so that @@ -357,7 +358,11 @@ let prepare_ashared_loans (meta : Meta.meta) (loop_id : LoopId.id option) : cm_f TODO: implement this more general behavior. *) method! visit_symbolic_value env sv = - cassert (not (symbolic_value_has_borrows ctx sv)) meta "There should be no symbolic values with borrows inside the abstraction"; + cassert + (not (symbolic_value_has_borrows ctx sv)) + meta + "There should be no symbolic values with borrows inside the \ + abstraction"; super#visit_symbolic_value env sv end in @@ -433,12 +438,12 @@ let prepare_ashared_loans (meta : Meta.meta) (loop_id : LoopId.id option) : cm_f SymbolicAst.IntroSymbolic (ctx, None, sv, VaSingleValue v, e)) e !sid_subst) -let prepare_ashared_loans_no_synth (meta : Meta.meta) (loop_id : LoopId.id) (ctx : eval_ctx) : - eval_ctx = +let prepare_ashared_loans_no_synth (meta : Meta.meta) (loop_id : LoopId.id) + (ctx : eval_ctx) : eval_ctx = get_cf_ctx_no_synth meta (prepare_ashared_loans meta (Some loop_id)) ctx -let compute_loop_entry_fixed_point (config : config) (meta : Meta.meta) (loop_id : LoopId.id) - (eval_loop_body : st_cm_fun) (ctx0 : eval_ctx) : +let compute_loop_entry_fixed_point (config : config) (meta : Meta.meta) + (loop_id : LoopId.id) (eval_loop_body : st_cm_fun) (ctx0 : eval_ctx) : eval_ctx * ids_sets * abs RegionGroupId.Map.t = (* The continuation for when we exit the loop - we register the environments upon loop *reentry*, and synthesize nothing by @@ -544,7 +549,8 @@ let compute_loop_entry_fixed_point (config : config) (meta : Meta.meta) (loop_id (* Join the context with the context at the loop entry *) let (_, _), ctx2 = - loop_join_origin_with_continue_ctxs config meta loop_id fixed_ids ctx1 !ctxs + loop_join_origin_with_continue_ctxs config meta loop_id fixed_ids ctx1 + !ctxs in ctxs := []; ctx2 @@ -582,10 +588,9 @@ let compute_loop_entry_fixed_point (config : config) (meta : Meta.meta) (loop_id let max_num_iter = Config.loop_fixed_point_max_num_iters in let rec compute_fixed_point (ctx : eval_ctx) (i0 : int) (i : int) : eval_ctx = if i = 0 then - craise - meta - ("Could not compute a loop fixed point in " ^ string_of_int i0 - ^ " iterations") + craise meta + ("Could not compute a loop fixed point in " ^ string_of_int i0 + ^ " iterations") else (* Evaluate the loop body to register the different contexts upon reentry *) let _ = eval_loop_body cf_exit_loop_body ctx in @@ -694,12 +699,14 @@ let compute_loop_entry_fixed_point (config : config) (meta : Meta.meta) (loop_id in (* By default, the [SynthInput] abs can't end *) let ctx = ctx_set_abs_can_end meta ctx abs_id true in - sanity_check ( - let abs = ctx_lookup_abs ctx abs_id in - abs.kind = SynthInput rg_id) meta; + sanity_check + (let abs = ctx_lookup_abs ctx abs_id in + abs.kind = SynthInput rg_id) + meta; (* End this abstraction *) let ctx = - InterpreterBorrows.end_abstraction_no_synth config meta abs_id ctx + InterpreterBorrows.end_abstraction_no_synth config meta abs_id + ctx in (* Explore the context, and check which abstractions are not there anymore *) let ids, _ = compute_ctx_ids ctx in @@ -718,7 +725,11 @@ let compute_loop_entry_fixed_point (config : config) (meta : Meta.meta) (loop_id let _ = RegionGroupId.Map.iter (fun _ ids -> - cassert (AbstractionId.Set.disjoint !aids_union ids) meta "The sets of abstractions we need to end per region group are not pairwise disjoint"; + cassert + (AbstractionId.Set.disjoint !aids_union ids) + meta + "The sets of abstractions we need to end per region group are not \ + pairwise disjoint"; aids_union := AbstractionId.Set.union ids !aids_union) !fp_ended_aids in @@ -777,7 +788,8 @@ let compute_loop_entry_fixed_point (config : config) (meta : Meta.meta) (loop_id ^ AbstractionId.to_string !id0)); (* Note that we merge *into* [id0] *) let fp', id0' = - merge_into_abstraction meta loop_id abs_kind false !fp id !id0 + merge_into_abstraction meta loop_id abs_kind false !fp id + !id0 in fp := fp'; id0 := id0'; @@ -850,13 +862,17 @@ let compute_loop_entry_fixed_point (config : config) (meta : Meta.meta) (loop_id (* Return *) (fp, fixed_ids, rg_to_abs) -let compute_fixed_point_id_correspondance (meta : Meta.meta) (fixed_ids : ids_sets) - (src_ctx : eval_ctx) (tgt_ctx : eval_ctx) : borrow_loan_corresp = +let compute_fixed_point_id_correspondance (meta : Meta.meta) + (fixed_ids : ids_sets) (src_ctx : eval_ctx) (tgt_ctx : eval_ctx) : + borrow_loan_corresp = log#ldebug (lazy ("compute_fixed_point_id_correspondance:\n\n- fixed_ids:\n" - ^ show_ids_sets fixed_ids ^ "\n\n- src_ctx:\n" ^ eval_ctx_to_string ~meta:(Some meta) src_ctx - ^ "\n\n- tgt_ctx:\n" ^ eval_ctx_to_string ~meta:(Some meta) tgt_ctx ^ "\n\n")); + ^ show_ids_sets fixed_ids ^ "\n\n- src_ctx:\n" + ^ eval_ctx_to_string ~meta:(Some meta) src_ctx + ^ "\n\n- tgt_ctx:\n" + ^ eval_ctx_to_string ~meta:(Some meta) tgt_ctx + ^ "\n\n")); let filt_src_env, _, _ = ctx_split_fixed_new meta fixed_ids src_ctx in let filt_src_ctx = { src_ctx with env = filt_src_env } in @@ -886,8 +902,8 @@ let compute_fixed_point_id_correspondance (meta : Meta.meta) (fixed_ids : ids_se let lookup_in_tgt id = lookup_shared_loan id tgt_ctx in let lookup_in_src id = lookup_shared_loan id src_ctx in Option.get - (match_ctxs meta check_equiv fixed_ids lookup_in_tgt lookup_in_src filt_tgt_ctx - filt_src_ctx) + (match_ctxs meta check_equiv fixed_ids lookup_in_tgt lookup_in_src + filt_tgt_ctx filt_src_ctx) in log#ldebug @@ -984,8 +1000,8 @@ let compute_fixed_point_id_correspondance (meta : Meta.meta) (fixed_ids : ids_se loan_to_borrow_id_map = tgt_loan_to_borrow; } -let compute_fp_ctx_symbolic_values (meta : Meta.meta) (ctx : eval_ctx) (fp_ctx : eval_ctx) : - SymbolicValueId.Set.t * symbolic_value list = +let compute_fp_ctx_symbolic_values (meta : Meta.meta) (ctx : eval_ctx) + (fp_ctx : eval_ctx) : SymbolicValueId.Set.t * symbolic_value list = let old_ids, _ = compute_ctx_ids ctx in let fp_ids, fp_ids_maps = compute_ctx_ids fp_ctx in let fresh_sids = SymbolicValueId.Set.diff fp_ids.sids old_ids.sids in diff --git a/compiler/InterpreterLoopsFixedPoint.mli b/compiler/InterpreterLoopsFixedPoint.mli index 54e4d780..4fc36598 100644 --- a/compiler/InterpreterLoopsFixedPoint.mli +++ b/compiler/InterpreterLoopsFixedPoint.mli @@ -77,7 +77,7 @@ val prepare_ashared_loans : Meta.meta -> loop_id option -> Cps.cm_fun the values which are read or modified (some symbolic values may be ignored). *) val compute_loop_entry_fixed_point : - config -> + config -> Meta.meta -> loop_id -> Cps.st_cm_fun -> @@ -170,4 +170,7 @@ val compute_fixed_point_id_correspondance : - the list of input symbolic values *) val compute_fp_ctx_symbolic_values : - Meta.meta -> eval_ctx -> eval_ctx -> symbolic_value_id_set * symbolic_value list + Meta.meta -> + eval_ctx -> + eval_ctx -> + symbolic_value_id_set * symbolic_value list diff --git a/compiler/InterpreterLoopsJoinCtxs.ml b/compiler/InterpreterLoopsJoinCtxs.ml index 8153ef08..020e812a 100644 --- a/compiler/InterpreterLoopsJoinCtxs.ml +++ b/compiler/InterpreterLoopsJoinCtxs.ml @@ -19,8 +19,8 @@ let log = Logging.loops_join_ctxs_log called typically after we merge abstractions together (see {!collapse_ctx} for instance). *) -let reorder_loans_borrows_in_fresh_abs (meta : Meta.meta) (old_abs_ids : AbstractionId.Set.t) - (ctx : eval_ctx) : eval_ctx = +let reorder_loans_borrows_in_fresh_abs (meta : Meta.meta) + (old_abs_ids : AbstractionId.Set.t) (ctx : eval_ctx) : eval_ctx = let reorder_in_fresh_abs (abs : abs) : abs = (* Split between the loans and borrows *) let is_borrow (av : typed_avalue) : bool = @@ -136,7 +136,9 @@ let collapse_ctx (meta : Meta.meta) (loop_id : LoopId.id) log#ldebug (lazy ("collapse_ctx:\n\n- fixed_ids:\n" ^ show_ids_sets old_ids - ^ "\n\n- ctx0:\n" ^ eval_ctx_to_string ~meta:(Some meta) ctx0 ^ "\n\n")); + ^ "\n\n- ctx0:\n" + ^ eval_ctx_to_string ~meta:(Some meta) ctx0 + ^ "\n\n")); let abs_kind : abs_kind = Loop (loop_id, None, LoopSynthInput) in let can_end = true in @@ -171,14 +173,16 @@ let collapse_ctx (meta : Meta.meta) (loop_id : LoopId.id) log#ldebug (lazy ("collapse_ctx: after converting values to abstractions:\n" - ^ show_ids_sets old_ids ^ "\n\n- ctx:\n" ^ eval_ctx_to_string ~meta:(Some meta) ctx ^ "\n\n" - )); + ^ show_ids_sets old_ids ^ "\n\n- ctx:\n" + ^ eval_ctx_to_string ~meta:(Some meta) ctx + ^ "\n\n")); log#ldebug (lazy ("collapse_ctx: after decomposing the shared values in the abstractions:\n" - ^ show_ids_sets old_ids ^ "\n\n- ctx:\n" ^ eval_ctx_to_string ~meta:(Some meta) ctx ^ "\n\n" - )); + ^ show_ids_sets old_ids ^ "\n\n- ctx:\n" + ^ eval_ctx_to_string ~meta:(Some meta) ctx + ^ "\n\n")); (* Explore all the *new* abstractions, and compute various maps *) let explore (abs : abs) = is_fresh_abs_id abs.abs_id in @@ -252,13 +256,14 @@ let collapse_ctx (meta : Meta.meta) (loop_id : LoopId.id) ^ AbstractionId.to_string abs_id1 ^ " into " ^ AbstractionId.to_string abs_id0 - ^ ":\n\n" ^ eval_ctx_to_string ~meta:(Some meta) !ctx)); + ^ ":\n\n" + ^ eval_ctx_to_string ~meta:(Some meta) !ctx)); (* Update the environment - pay attention to the order: we we merge [abs_id1] *into* [abs_id0] *) let nctx, abs_id = - merge_into_abstraction meta abs_kind can_end merge_funs !ctx - abs_id1 abs_id0 + merge_into_abstraction meta abs_kind can_end merge_funs + !ctx abs_id1 abs_id0 in ctx := nctx; @@ -272,7 +277,9 @@ let collapse_ctx (meta : Meta.meta) (loop_id : LoopId.id) log#ldebug (lazy ("collapse_ctx:\n\n- fixed_ids:\n" ^ show_ids_sets old_ids - ^ "\n\n- after collapse:\n" ^ eval_ctx_to_string ~meta:(Some meta) !ctx ^ "\n\n")); + ^ "\n\n- after collapse:\n" + ^ eval_ctx_to_string ~meta:(Some meta) !ctx + ^ "\n\n")); (* Reorder the loans and borrows in the fresh abstractions *) let ctx = reorder_loans_borrows_in_fresh_abs meta old_ids.aids !ctx in @@ -281,13 +288,14 @@ let collapse_ctx (meta : Meta.meta) (loop_id : LoopId.id) (lazy ("collapse_ctx:\n\n- fixed_ids:\n" ^ show_ids_sets old_ids ^ "\n\n- after collapse and reorder borrows/loans:\n" - ^ eval_ctx_to_string ~meta:(Some meta) ctx ^ "\n\n")); + ^ eval_ctx_to_string ~meta:(Some meta) ctx + ^ "\n\n")); (* Return the new context *) ctx -let mk_collapse_ctx_merge_duplicate_funs (meta : Meta.meta) (loop_id : LoopId.id) (ctx : eval_ctx) - : merge_duplicates_funcs = +let mk_collapse_ctx_merge_duplicate_funs (meta : Meta.meta) + (loop_id : LoopId.id) (ctx : eval_ctx) : merge_duplicates_funcs = (* Rem.: the merge functions raise exceptions (that we catch). *) let module S : MatchJoinState = struct let meta = meta @@ -372,9 +380,10 @@ let mk_collapse_ctx_merge_duplicate_funs (meta : Meta.meta) (loop_id : LoopId.id merge_ashared_loans; } -let merge_into_abstraction (meta : Meta.meta) (loop_id : LoopId.id) (abs_kind : abs_kind) - (can_end : bool) (ctx : eval_ctx) (aid0 : AbstractionId.id) - (aid1 : AbstractionId.id) : eval_ctx * AbstractionId.id = +let merge_into_abstraction (meta : Meta.meta) (loop_id : LoopId.id) + (abs_kind : abs_kind) (can_end : bool) (ctx : eval_ctx) + (aid0 : AbstractionId.id) (aid1 : AbstractionId.id) : + eval_ctx * AbstractionId.id = let merge_funs = mk_collapse_ctx_merge_duplicate_funs meta loop_id ctx in merge_into_abstraction meta abs_kind can_end (Some merge_funs) ctx aid0 aid1 @@ -385,14 +394,14 @@ let merge_into_abstraction (meta : Meta.meta) (loop_id : LoopId.id) (abs_kind : We do this because when we join environments, we may introduce duplicated loans and borrows. See the explanations for {!join_ctxs}. *) -let collapse_ctx_with_merge (meta : Meta.meta) (loop_id : LoopId.id) (old_ids : ids_sets) - (ctx : eval_ctx) : eval_ctx = +let collapse_ctx_with_merge (meta : Meta.meta) (loop_id : LoopId.id) + (old_ids : ids_sets) (ctx : eval_ctx) : eval_ctx = let merge_funs = mk_collapse_ctx_merge_duplicate_funs meta loop_id ctx in try collapse_ctx meta loop_id (Some merge_funs) old_ids ctx with ValueMatchFailure _ -> craise meta "Unexpected" -let join_ctxs (meta : Meta.meta) (loop_id : LoopId.id) (fixed_ids : ids_sets) (ctx0 : eval_ctx) - (ctx1 : eval_ctx) : ctx_or_update = +let join_ctxs (meta : Meta.meta) (loop_id : LoopId.id) (fixed_ids : ids_sets) + (ctx0 : eval_ctx) (ctx1 : eval_ctx) : ctx_or_update = (* Debug *) log#ldebug (lazy @@ -414,9 +423,11 @@ let join_ctxs (meta : Meta.meta) (loop_id : LoopId.id) (fixed_ids : ids_sets) (c (lazy ("join_suffixes:\n\n- fixed_ids:\n" ^ show_ids_sets fixed_ids ^ "\n\n- ctx0:\n" - ^ eval_ctx_to_string_no_filter ~meta:(Some meta) { ctx0 with env = List.rev env0 } + ^ eval_ctx_to_string_no_filter ~meta:(Some meta) + { ctx0 with env = List.rev env0 } ^ "\n\n- ctx1:\n" - ^ eval_ctx_to_string_no_filter ~meta:(Some meta) { ctx1 with env = List.rev env1 } + ^ eval_ctx_to_string_no_filter ~meta:(Some meta) + { ctx1 with env = List.rev env1 } ^ "\n\n")); (* Sanity check: there are no values/abstractions which should be in the prefix *) @@ -428,7 +439,9 @@ let join_ctxs (meta : Meta.meta) (loop_id : LoopId.id) (fixed_ids : ids_sets) (c | EBinding (BDummy did, _) -> sanity_check (not (DummyVarId.Set.mem did fixed_ids.dids)) meta | EAbs abs -> - sanity_check (not (AbstractionId.Set.mem abs.abs_id fixed_ids.aids)) meta + sanity_check + (not (AbstractionId.Set.mem abs.abs_id fixed_ids.aids)) + meta | EFrame -> (* This should have been eliminated *) craise meta "Unreachable" @@ -468,7 +481,8 @@ let join_ctxs (meta : Meta.meta) (loop_id : LoopId.id) (fixed_ids : ids_sets) (c are not in the prefix anymore *) if DummyVarId.Set.mem b0 fixed_ids.dids then ( (* Still in the prefix: match the values *) - cassert (b0 = b1) meta "Bindings are not the same. We are not in the prefix anymore"; + cassert (b0 = b1) meta + "Bindings are not the same. We are not in the prefix anymore"; let b = b0 in let v = M.match_typed_values ctx0 ctx1 v0 v1 in let var = EBinding (BDummy b, v) in @@ -490,8 +504,9 @@ let join_ctxs (meta : Meta.meta) (loop_id : LoopId.id) (fixed_ids : ids_sets) (c (* Variable bindings *must* be in the prefix and consequently their ids must be the same *) - cassert (b0 = b1) meta "Variable bindings *must* be in the prefix and consequently their - ids must be the same"; + cassert (b0 = b1) meta + "Variable bindings *must* be in the prefix and consequently their\n\ + \ ids must be the same"; (* Match the values *) let b = b0 in let v = M.match_typed_values ctx0 ctx1 v0 v1 in @@ -503,8 +518,11 @@ let join_ctxs (meta : Meta.meta) (loop_id : LoopId.id) (fixed_ids : ids_sets) (c log#ldebug (lazy ("join_prefixes: Abs:\n\n- fixed_ids:\n" ^ "\n" - ^ show_ids_sets fixed_ids ^ "\n\n- abs0:\n" ^ abs_to_string meta ctx0 abs0 - ^ "\n\n- abs1:\n" ^ abs_to_string meta ctx1 abs1 ^ "\n\n")); + ^ show_ids_sets fixed_ids ^ "\n\n- abs0:\n" + ^ abs_to_string meta ctx0 abs0 + ^ "\n\n- abs1:\n" + ^ abs_to_string meta ctx1 abs1 + ^ "\n\n")); (* Same as for the dummy values: there are two cases *) if AbstractionId.Set.mem abs0.abs_id fixed_ids.aids then ( @@ -599,7 +617,8 @@ let destructure_new_abs (meta : Meta.meta) (loop_id : LoopId.id) (fun abs -> if is_fresh_abs_id abs.abs_id then let abs = - destructure_abs meta abs_kind can_end destructure_shared_values ctx abs + destructure_abs meta abs_kind can_end destructure_shared_values ctx + abs in abs else abs) @@ -638,9 +657,9 @@ let refresh_abs (old_abs : AbstractionId.Set.t) (ctx : eval_ctx) : eval_ctx = in { ctx with env } -let loop_join_origin_with_continue_ctxs (config : config) (meta : Meta.meta) (loop_id : LoopId.id) - (fixed_ids : ids_sets) (old_ctx : eval_ctx) (ctxl : eval_ctx list) : - (eval_ctx * eval_ctx list) * eval_ctx = +let loop_join_origin_with_continue_ctxs (config : config) (meta : Meta.meta) + (loop_id : LoopId.id) (fixed_ids : ids_sets) (old_ctx : eval_ctx) + (ctxl : eval_ctx list) : (eval_ctx * eval_ctx list) * eval_ctx = (* # Join with the new contexts, one by one For every context, we repeteadly attempt to join it with the current @@ -671,21 +690,21 @@ let loop_join_origin_with_continue_ctxs (config : config) (meta : Meta.meta) (lo log#ldebug (lazy ("loop_join_origin_with_continue_ctxs:join_one: initial ctx:\n" - ^ eval_ctx_to_string ~meta:(Some meta) ctx)); + ^ eval_ctx_to_string ~meta:(Some meta) ctx)); (* Destructure the abstractions introduced in the new context *) let ctx = destructure_new_abs meta loop_id fixed_ids.aids ctx in log#ldebug (lazy ("loop_join_origin_with_continue_ctxs:join_one: after destructure:\n" - ^ eval_ctx_to_string ~meta:(Some meta) ctx)); + ^ eval_ctx_to_string ~meta:(Some meta) ctx)); (* Collapse the context we want to add to the join *) let ctx = collapse_ctx meta loop_id None fixed_ids ctx in log#ldebug (lazy ("loop_join_origin_with_continue_ctxs:join_one: after collapse:\n" - ^ eval_ctx_to_string ~meta:(Some meta) ctx)); + ^ eval_ctx_to_string ~meta:(Some meta) ctx)); (* Refresh the fresh abstractions *) let ctx = refresh_abs fixed_ids.aids ctx in @@ -695,7 +714,7 @@ let loop_join_origin_with_continue_ctxs (config : config) (meta : Meta.meta) (lo log#ldebug (lazy ("loop_join_origin_with_continue_ctxs:join_one: after join:\n" - ^ eval_ctx_to_string ~meta:(Some meta) ctx1)); + ^ eval_ctx_to_string ~meta:(Some meta) ctx1)); (* Collapse again - the join might have introduce abstractions we want to merge with the others (note that those abstractions may actually diff --git a/compiler/InterpreterLoopsJoinCtxs.mli b/compiler/InterpreterLoopsJoinCtxs.mli index d92b3750..0e84657c 100644 --- a/compiler/InterpreterLoopsJoinCtxs.mli +++ b/compiler/InterpreterLoopsJoinCtxs.mli @@ -85,7 +85,8 @@ val merge_into_abstraction : - [ctx0] - [ctx1] *) -val join_ctxs : Meta.meta -> loop_id -> ids_sets -> eval_ctx -> eval_ctx -> ctx_or_update +val join_ctxs : + Meta.meta -> loop_id -> ids_sets -> eval_ctx -> eval_ctx -> ctx_or_update (** Join the context at the entry of the loop with the contexts upon reentry (upon reaching the [Continue] statement - the goal is to compute a fixed diff --git a/compiler/InterpreterLoopsMatchCtxs.ml b/compiler/InterpreterLoopsMatchCtxs.ml index 24e588f2..1a6e6926 100644 --- a/compiler/InterpreterLoopsMatchCtxs.ml +++ b/compiler/InterpreterLoopsMatchCtxs.ml @@ -43,8 +43,9 @@ let compute_abs_borrows_loans_maps (meta : Meta.meta) (no_duplicates : bool) match Id0.Map.find_opt id0 !map with | None -> () | Some set -> - sanity_check ( - (not check_not_already_registered) || not (Id1.Set.mem id1 set)) meta); + sanity_check + ((not check_not_already_registered) || not (Id1.Set.mem id1 set)) + meta); (* Update the mapping *) map := Id0.Map.update id0 @@ -54,9 +55,10 @@ let compute_abs_borrows_loans_maps (meta : Meta.meta) (no_duplicates : bool) | Some ids -> (* Sanity check *) sanity_check (not check_singleton_sets) meta; - sanity_check ( - (not check_not_already_registered) - || not (Id1.Set.mem id1 ids)) meta; + sanity_check + ((not check_not_already_registered) + || not (Id1.Set.mem id1 ids)) + meta; (* Update *) Some (Id1.Set.add id1 ids)) !map @@ -107,8 +109,7 @@ let compute_abs_borrows_loans_maps (meta : Meta.meta) (no_duplicates : bool) -> (* Ignore the id of the borrow, if there is *) self#visit_typed_avalue abs_id child - | AEndedMutBorrow _ | AEndedSharedBorrow -> - craise meta "Unreachable" + | AEndedMutBorrow _ | AEndedSharedBorrow -> craise meta "Unreachable" method! visit_borrow_id abs_id bid = register_borrow_id abs_id bid method! visit_loan_id abs_id lid = register_loan_id abs_id lid @@ -185,6 +186,7 @@ let rec match_types (meta : Meta.meta) (match_distinct_types : ty -> ty -> ty) module MakeMatcher (M : PrimMatcher) : Matcher = struct let meta = M.meta + let rec match_typed_values (ctx0 : eval_ctx) (ctx1 : eval_ctx) (v0 : typed_value) (v1 : typed_value) : typed_value = let match_rec = match_typed_values ctx0 ctx1 in @@ -227,10 +229,11 @@ module MakeMatcher (M : PrimMatcher) : Matcher = struct | VMutBorrow (bid0, bv0), VMutBorrow (bid1, bv1) -> let bv = match_rec bv0 bv1 in - cassert ( - not - (ValuesUtils.value_has_borrows ctx0.type_ctx.type_infos - bv.value)) M.meta "TODO: error message"; + cassert + (not + (ValuesUtils.value_has_borrows ctx0.type_ctx.type_infos + bv.value)) + M.meta "TODO: error message"; let bid, bv = M.match_mut_borrows ctx0 ctx1 ty bid0 bv0 bid1 bv1 bv in @@ -253,7 +256,9 @@ module MakeMatcher (M : PrimMatcher) : Matcher = struct match (lc0, lc1) with | VSharedLoan (ids0, sv0), VSharedLoan (ids1, sv1) -> let sv = match_rec sv0 sv1 in - cassert (not (value_has_borrows sv.value)) M.meta "TODO: error message"; + cassert + (not (value_has_borrows sv.value)) + M.meta "TODO: error message"; let ids, sv = M.match_shared_loans ctx0 ctx1 ty ids0 ids1 sv in VSharedLoan (ids, sv) | VMutLoan id0, VMutLoan id1 -> @@ -266,8 +271,16 @@ module MakeMatcher (M : PrimMatcher) : Matcher = struct | VSymbolic sv0, VSymbolic sv1 -> (* For now, we force all the symbolic values containing borrows to be eagerly expanded, and we don't support nested borrows *) - cassert (not (value_has_borrows v0.value)) M.meta "Nested borrows are not supported yet and all the symbolic values containing borrows are currently forced to be eagerly expanded"; - cassert (not (value_has_borrows v1.value)) M.meta "Nested borrows are not supported yet and all the symbolic values containing borrows are currently forced to be eagerly expanded"; + cassert + (not (value_has_borrows v0.value)) + M.meta + "Nested borrows are not supported yet and all the symbolic values \ + containing borrows are currently forced to be eagerly expanded"; + cassert + (not (value_has_borrows v1.value)) + M.meta + "Nested borrows are not supported yet and all the symbolic values \ + containing borrows are currently forced to be eagerly expanded"; (* Match *) let sv = M.match_symbolic_values ctx0 ctx1 sv0 sv1 in { v1 with value = VSymbolic sv } @@ -401,25 +414,25 @@ end module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct (** Small utility *) let meta = S.meta - let push_abs (abs : abs) : unit = S.nabs := abs :: !S.nabs + let push_abs (abs : abs) : unit = S.nabs := abs :: !S.nabs let push_absl (absl : abs list) : unit = List.iter push_abs absl - let match_etys _ _ ty0 ty1 = + let match_etys _ _ ty0 ty1 = sanity_check (ty0 = ty1) meta; ty0 - let match_rtys _ _ ty0 ty1 = + let match_rtys _ _ ty0 ty1 = (* The types must be equal - in effect, this forbids to match symbolic values containing borrows *) sanity_check (ty0 = ty1) meta; ty0 - let match_distinct_literals (_ : eval_ctx) (_ : eval_ctx) (ty : ety) + let match_distinct_literals (_ : eval_ctx) (_ : eval_ctx) (ty : ety) (_ : literal) (_ : literal) : typed_value = mk_fresh_symbolic_typed_value_from_no_regions_ty meta ty - let match_distinct_adts (ctx0 : eval_ctx) (ctx1 : eval_ctx) (ty : ety) + let match_distinct_adts (ctx0 : eval_ctx) (ctx1 : eval_ctx) (ty : ety) (adt0 : adt_value) (adt1 : adt_value) : typed_value = (* Check that the ADTs don't contain borrows - this is redundant with checks performed by the caller, but we prefer to be safe with regards to future @@ -454,7 +467,7 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct (* No borrows, no loans, no bottoms: we can introduce a symbolic value *) mk_fresh_symbolic_typed_value_from_no_regions_ty meta ty - let match_shared_borrows (ctx0 : eval_ctx) (ctx1 : eval_ctx) match_rec + let match_shared_borrows (ctx0 : eval_ctx) (ctx1 : eval_ctx) match_rec (ty : ety) (bid0 : borrow_id) (bid1 : borrow_id) : borrow_id = (* Lookup the shared values and match them - we do this mostly to make sure we end loans which might appear on one side @@ -510,7 +523,7 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct (* Return the new borrow *) bid2 - let match_mut_borrows (ctx0 : eval_ctx) (_ : eval_ctx) (ty : ety) + let match_mut_borrows (ctx0 : eval_ctx) (_ : eval_ctx) (ty : ety) (bid0 : borrow_id) (bv0 : typed_value) (bid1 : borrow_id) (bv1 : typed_value) (bv : typed_value) : borrow_id * typed_value = if bid0 = bid1 then ( @@ -561,8 +574,9 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct do so, we won't introduce reborrows like above: the forward loop function will update [v], while the backward loop function will return nothing. *) - cassert ( - not (ValuesUtils.value_has_borrows ctx0.type_ctx.type_infos bv.value)) meta "Nested borrows are not supported yet"; + cassert + (not (ValuesUtils.value_has_borrows ctx0.type_ctx.type_infos bv.value)) + meta "Nested borrows are not supported yet"; if bv0 = bv1 then ( sanity_check (bv0 = bv) meta; @@ -626,7 +640,8 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct (* Generate the avalues for the abstraction *) let mk_aborrow (bid : borrow_id) (bv : typed_value) : typed_avalue = let bv_ty = bv.ty in - cassert (ty_no_regions bv_ty) meta "Nested borrows are not supported yet"; + cassert (ty_no_regions bv_ty) meta + "Nested borrows are not supported yet"; let value = ABorrow (AMutBorrow (bid, mk_aignored meta bv_ty)) in { value; ty = borrow_ty } in @@ -656,7 +671,7 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct (* Return the new borrow *) (bid2, sv) - let match_shared_loans (_ : eval_ctx) (_ : eval_ctx) (_ : ety) + let match_shared_loans (_ : eval_ctx) (_ : eval_ctx) (_ : ety) (ids0 : loan_id_set) (ids1 : loan_id_set) (sv : typed_value) : loan_id_set * typed_value = (* Check if the ids are the same - Rem.: we forbid the sets of loans @@ -687,7 +702,7 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct both borrows *) raise (ValueMatchFailure (LoanInLeft id0)) - let match_symbolic_values (ctx0 : eval_ctx) (_ : eval_ctx) + let match_symbolic_values (ctx0 : eval_ctx) (_ : eval_ctx) (sv0 : symbolic_value) (sv1 : symbolic_value) : symbolic_value = let id0 = sv0.sv_id in let id1 = sv1.sv_id in @@ -699,11 +714,13 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct else ( (* The caller should have checked that the symbolic values don't contain borrows *) - sanity_check (not (ty_has_borrows ctx0.type_ctx.type_infos sv0.sv_ty)) meta; + sanity_check + (not (ty_has_borrows ctx0.type_ctx.type_infos sv0.sv_ty)) + meta; (* We simply introduce a fresh symbolic value *) mk_fresh_symbolic_value meta sv0.sv_ty) - let match_symbolic_with_other (ctx0 : eval_ctx) (_ : eval_ctx) (left : bool) + let match_symbolic_with_other (ctx0 : eval_ctx) (_ : eval_ctx) (left : bool) (sv : symbolic_value) (v : typed_value) : typed_value = (* Check that: - there are no borrows in the symbolic value @@ -711,14 +728,20 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct If there are loans in the regular value, raise an exception. *) let type_infos = ctx0.type_ctx.type_infos in - cassert (not (ty_has_borrows type_infos sv.sv_ty)) meta "Check that: - - there are no borrows in the symbolic value - - there are no borrows in the \"regular\" value - If there are loans in the regular value, raise an exception."; - cassert (not (ValuesUtils.value_has_borrows type_infos v.value)) meta "Check that: - - there are no borrows in the symbolic value - - there are no borrows in the \"regular\" value - If there are loans in the regular value, raise an exception."; + cassert + (not (ty_has_borrows type_infos sv.sv_ty)) + meta + "Check that:\n\ + \ - there are no borrows in the symbolic value\n\ + \ - there are no borrows in the \"regular\" value\n\ + \ If there are loans in the regular value, raise an exception."; + cassert + (not (ValuesUtils.value_has_borrows type_infos v.value)) + meta + "Check that:\n\ + \ - there are no borrows in the symbolic value\n\ + \ - there are no borrows in the \"regular\" value\n\ + \ If there are loans in the regular value, raise an exception."; let value_is_left = not left in (match InterpreterBorrowsCore.get_first_loan_in_value v with | None -> () @@ -731,7 +754,7 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct (* Return a fresh symbolic value *) mk_fresh_symbolic_typed_value meta sv.sv_ty - let match_bottom_with_other (ctx0 : eval_ctx) (ctx1 : eval_ctx) (left : bool) + let match_bottom_with_other (ctx0 : eval_ctx) (ctx1 : eval_ctx) (left : bool) (v : typed_value) : typed_value = (* If there are outer loans in the non-bottom value, raise an exception. Otherwise, convert it to an abstraction and return [Bottom]. @@ -775,10 +798,7 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct let match_distinct_aadts _ _ _ _ _ _ _ = craise meta "Unreachable" let match_ashared_borrows _ _ _ _ _ _ = craise meta "Unreachable" let match_amut_borrows _ _ _ _ _ _ _ _ _ _ = craise meta "Unreachable" - - let match_ashared_loans _ _ _ _ _ _ _ _ _ _ _ _ _ = - craise meta "Unreachable" - + let match_ashared_loans _ _ _ _ _ _ _ _ _ _ _ _ _ = craise meta "Unreachable" let match_amut_loans _ _ _ _ _ _ _ _ _ _ = craise meta "Unreachable" let match_avalues _ _ _ _ = craise meta "Unreachable" end @@ -790,6 +810,7 @@ module type MatchMoveState = sig (** The moved values *) val nvalues : typed_value list ref + val meta : Meta.meta end @@ -812,13 +833,14 @@ end module MakeMoveMatcher (S : MatchMoveState) : PrimMatcher = struct (** Small utility *) let meta = S.meta + let push_moved_value (v : typed_value) : unit = S.nvalues := v :: !S.nvalues - let match_etys _ _ ty0 ty1 = + let match_etys _ _ ty0 ty1 = sanity_check (ty0 = ty1) meta; ty0 - let match_rtys _ _ ty0 ty1 = + let match_rtys _ _ ty0 ty1 = (* The types must be equal - in effect, this forbids to match symbolic values containing borrows *) sanity_check (ty0 = ty1) meta; @@ -863,7 +885,7 @@ module MakeMoveMatcher (S : MatchMoveState) : PrimMatcher = struct (sv : symbolic_value) (v : typed_value) : typed_value = if left then v else mk_typed_value_from_symbolic_value sv - let match_bottom_with_other (_ : eval_ctx) (_ : eval_ctx) (left : bool) + let match_bottom_with_other (_ : eval_ctx) (_ : eval_ctx) (left : bool) (v : typed_value) : typed_value = let with_borrows = false in if left then ( @@ -898,18 +920,16 @@ module MakeMoveMatcher (S : MatchMoveState) : PrimMatcher = struct let match_distinct_aadts _ _ _ _ _ _ _ = craise meta "Unreachable" let match_ashared_borrows _ _ _ _ _ _ = craise meta "Unreachable" let match_amut_borrows _ _ _ _ _ _ _ _ _ = craise meta "Unreachable" - - let match_ashared_loans _ _ _ _ _ _ _ _ _ _ _ _ _ = - craise meta "Unreachable" - - let match_amut_loans _ _ _ _ _ _ _ _ _ _ = craise meta "Unreachable" - let match_avalues _ _ _ _ = craise meta "Unreachable" + let match_ashared_loans _ _ _ _ _ _ _ _ _ _ _ _ _ = craise meta "Unreachable" + let match_amut_loans _ _ _ _ _ _ _ _ _ _ = craise meta "Unreachable" + let match_avalues _ _ _ _ = craise meta "Unreachable" end module MakeCheckEquivMatcher (S : MatchCheckEquivState) : CheckEquivMatcher = struct module MkGetSetM (Id : Identifiers.Id) = struct module Inj = Id.InjSubst + let add (msg : string) (m : Inj.t ref) (k0 : Id.id) (k1 : Id.id) = (* Check if k0 is already registered as a key *) match Inj.find_opt k0 !m with @@ -948,7 +968,9 @@ struct Id.Set.of_list (match_el msg m (Id.Set.elements ks0) (Id.Set.elements ks1)) end + let meta = S.meta + module GetSetRid = MkGetSetM (RegionId) let match_rid = GetSetRid.match_e "match_rid: " S.rid_map @@ -995,7 +1017,7 @@ struct let match_etys (_ : eval_ctx) (_ : eval_ctx) ty0 ty1 = if ty0 <> ty1 then raise (Distinct "match_etys") else ty0 - let match_rtys (_ : eval_ctx) (_ : eval_ctx) ty0 ty1 = + let match_rtys (_ : eval_ctx) (_ : eval_ctx) ty0 ty1 = let match_distinct_types _ _ = raise (Distinct "match_rtys") in let match_regions r0 r1 = match (r0, r1) with @@ -1007,7 +1029,7 @@ struct in match_types meta match_distinct_types match_regions ty0 ty1 - let match_distinct_literals (_ : eval_ctx) (_ : eval_ctx) (ty : ety) + let match_distinct_literals (_ : eval_ctx) (_ : eval_ctx) (ty : ety) (_ : literal) (_ : literal) : typed_value = mk_fresh_symbolic_typed_value_from_no_regions_ty meta ty @@ -1015,7 +1037,7 @@ struct (_adt0 : adt_value) (_adt1 : adt_value) : typed_value = raise (Distinct "match_distinct_adts") - let match_shared_borrows (ctx0 : eval_ctx) (ctx1 : eval_ctx) + let match_shared_borrows (ctx0 : eval_ctx) (ctx1 : eval_ctx) (match_typed_values : typed_value -> typed_value -> typed_value) (_ty : ety) (bid0 : borrow_id) (bid1 : borrow_id) : borrow_id = log#ldebug @@ -1061,7 +1083,7 @@ struct (bid1 : loan_id) : loan_id = match_loan_id bid0 bid1 - let match_symbolic_values (ctx0 : eval_ctx) (ctx1 : eval_ctx) + let match_symbolic_values (ctx0 : eval_ctx) (ctx1 : eval_ctx) (sv0 : symbolic_value) (sv1 : symbolic_value) : symbolic_value = let id0 = sv0.sv_id in let id1 = sv1.sv_id in @@ -1085,7 +1107,9 @@ struct sv else ( (* Check: fixed values are fixed *) - sanity_check (id0 = id1 || not (SymbolicValueId.InjSubst.mem id0 !S.sid_map)) meta; + sanity_check + (id0 = id1 || not (SymbolicValueId.InjSubst.mem id0 !S.sid_map)) + meta; (* Update the symbolic value mapping *) let sv1 = mk_typed_value_from_symbolic_value sv1 in @@ -1098,7 +1122,7 @@ struct we want *) sv0) - let match_symbolic_with_other (_ : eval_ctx) (_ : eval_ctx) (left : bool) + let match_symbolic_with_other (_ : eval_ctx) (_ : eval_ctx) (left : bool) (sv : symbolic_value) (v : typed_value) : typed_value = if S.check_equiv then raise (Distinct "match_symbolic_with_other") else ( @@ -1112,7 +1136,7 @@ struct (* Return - the returned value is not used, so we can return whatever we want *) v) - let match_bottom_with_other (ctx0 : eval_ctx) (ctx1 : eval_ctx) (left : bool) + let match_bottom_with_other (ctx0 : eval_ctx) (ctx1 : eval_ctx) (left : bool) (v : typed_value) : typed_value = (* It can happen that some variables get initialized in some branches and not in some others, which causes problems when matching. *) @@ -1121,7 +1145,8 @@ struct a continue, where the fixed point contains some bottom values. *) let value_is_left = not left in let ctx = if value_is_left then ctx0 else ctx1 in - if left && not (value_has_loans_or_borrows ctx v.value) then mk_bottom meta v.ty + if left && not (value_has_loans_or_borrows ctx v.value) then + mk_bottom meta v.ty else raise (Distinct @@ -1150,7 +1175,7 @@ struct let value = ALoan (ASharedLoan (bids, v, av)) in { value; ty } - let match_amut_loans (ctx0 : eval_ctx) (ctx1 : eval_ctx) _ty0 id0 _av0 _ty1 + let match_amut_loans (ctx0 : eval_ctx) (ctx1 : eval_ctx) _ty0 id0 _av0 _ty1 id1 _av1 ty av = log#ldebug (lazy @@ -1163,7 +1188,7 @@ struct let value = ALoan (AMutLoan (id, av)) in { value; ty } - let match_avalues (ctx0 : eval_ctx) (ctx1 : eval_ctx) v0 v1 = + let match_avalues (ctx0 : eval_ctx) (ctx1 : eval_ctx) v0 v1 = log#ldebug (lazy ("avalues don't match:\n- v0: " @@ -1313,22 +1338,25 @@ let match_ctxs (meta : Meta.meta) (check_equiv : bool) (fixed_ids : ids_sets) ^ "\n- aid_map: " ^ AbstractionId.InjSubst.show_t !aid_map ^ "\n\n- ctx0:\n" - ^ eval_ctx_to_string_no_filter ~meta:(Some meta) { ctx0 with env = List.rev env0 } + ^ eval_ctx_to_string_no_filter ~meta:(Some meta) + { ctx0 with env = List.rev env0 } ^ "\n\n- ctx1:\n" - ^ eval_ctx_to_string_no_filter ~meta:(Some meta) { ctx1 with env = List.rev env1 } + ^ eval_ctx_to_string_no_filter ~meta:(Some meta) + { ctx1 with env = List.rev env1 } ^ "\n\n")); match (env0, env1) with | EBinding (BDummy b0, v0) :: env0', EBinding (BDummy b1, v1) :: env1' -> (* Sanity check: if the dummy value is an old value, the bindings must be the same and their values equal (and the borrows/loans/symbolic *) - if DummyVarId.Set.mem b0 fixed_ids.dids then ( - (* Fixed values: the values must be equal *) - sanity_check (b0 = b1) meta; - sanity_check (v0 = v1) meta; - (* The ids present in the left value must be fixed *) - let ids, _ = compute_typed_value_ids v0 in - sanity_check ((not S.check_equiv) || ids_are_fixed ids)) meta; + if DummyVarId.Set.mem b0 fixed_ids.dids then + ((* Fixed values: the values must be equal *) + sanity_check (b0 = b1) meta; + sanity_check (v0 = v1) meta; + (* The ids present in the left value must be fixed *) + let ids, _ = compute_typed_value_ids v0 in + sanity_check ((not S.check_equiv) || ids_are_fixed ids)) + meta; (* We still match the values - allows to compute mappings (which are the identity actually) *) let _ = M.match_typed_values ctx0 ctx1 v0 v1 in @@ -1396,24 +1424,25 @@ let match_ctxs (meta : Meta.meta) (check_equiv : bool) (fixed_ids : ids_sets) log#ldebug (lazy ("match_ctxs: distinct: " ^ msg)); None -let ctxs_are_equivalent (meta : Meta.meta) (fixed_ids : ids_sets) (ctx0 : eval_ctx) - (ctx1 : eval_ctx) : bool = +let ctxs_are_equivalent (meta : Meta.meta) (fixed_ids : ids_sets) + (ctx0 : eval_ctx) (ctx1 : eval_ctx) : bool = let check_equivalent = true in let lookup_shared_value _ = craise meta "Unreachable" in Option.is_some (match_ctxs meta check_equivalent fixed_ids lookup_shared_value lookup_shared_value ctx0 ctx1) -let prepare_match_ctx_with_target (config : config) (meta : Meta.meta) (loop_id : LoopId.id) - (fixed_ids : ids_sets) (src_ctx : eval_ctx) : cm_fun = +let prepare_match_ctx_with_target (config : config) (meta : Meta.meta) + (loop_id : LoopId.id) (fixed_ids : ids_sets) (src_ctx : eval_ctx) : cm_fun = fun cf tgt_ctx -> (* Debug *) log#ldebug (lazy ("prepare_match_ctx_with_target:\n" ^ "\n- fixed_ids: " ^ show_ids_sets fixed_ids ^ "\n" ^ "\n- src_ctx: " - ^ eval_ctx_to_string ~meta:(Some meta) src_ctx ^ "\n- tgt_ctx: " ^ eval_ctx_to_string ~meta:(Some meta) tgt_ctx - )); + ^ eval_ctx_to_string ~meta:(Some meta) src_ctx + ^ "\n- tgt_ctx: " + ^ eval_ctx_to_string ~meta:(Some meta) tgt_ctx)); (* End the loans which lead to mismatches when joining *) let rec cf_reorganize_join_tgt : cm_fun = fun cf tgt_ctx -> @@ -1526,8 +1555,9 @@ let prepare_match_ctx_with_target (config : config) (meta : Meta.meta) (loop_id (lazy ("cf_reorganize_join_tgt: done with borrows/loans and moves:\n" ^ "\n- fixed_ids: " ^ show_ids_sets fixed_ids ^ "\n" ^ "\n- src_ctx: " - ^ eval_ctx_to_string ~meta:(Some meta) src_ctx ^ "\n- tgt_ctx: " - ^ eval_ctx_to_string ~meta:(Some meta) tgt_ctx)); + ^ eval_ctx_to_string ~meta:(Some meta) src_ctx + ^ "\n- tgt_ctx: " + ^ eval_ctx_to_string ~meta:(Some meta) tgt_ctx)); cf tgt_ctx with ValueMatchFailure e -> @@ -1544,8 +1574,9 @@ let prepare_match_ctx_with_target (config : config) (meta : Meta.meta) (loop_id (* Apply the reorganization *) cf_reorganize_join_tgt cf tgt_ctx -let match_ctx_with_target (config : config) (meta : Meta.meta) (loop_id : LoopId.id) - (is_loop_entry : bool) (fp_bl_maps : borrow_loan_corresp) +let match_ctx_with_target (config : config) (meta : Meta.meta) + (loop_id : LoopId.id) (is_loop_entry : bool) + (fp_bl_maps : borrow_loan_corresp) (fp_input_svalues : SymbolicValueId.id list) (fixed_ids : ids_sets) (src_ctx : eval_ctx) : st_cm_fun = fun cf tgt_ctx -> @@ -1628,8 +1659,10 @@ let match_ctx_with_target (config : config) (meta : Meta.meta) (loop_id : LoopId log#ldebug (lazy ("match_ctx_with_target: cf_introduce_loop_fp_abs:" ^ "\n\n- src_ctx: " - ^ eval_ctx_to_string ~meta:(Some meta) src_ctx ^ "\n\n- tgt_ctx: " - ^ eval_ctx_to_string ~meta:(Some meta) tgt_ctx ^ "\n\n- filt_tgt_ctx: " + ^ eval_ctx_to_string ~meta:(Some meta) src_ctx + ^ "\n\n- tgt_ctx: " + ^ eval_ctx_to_string ~meta:(Some meta) tgt_ctx + ^ "\n\n- filt_tgt_ctx: " ^ eval_ctx_to_string_no_filter ~meta:(Some meta) filt_tgt_ctx ^ "\n\n- filt_src_ctx: " ^ eval_ctx_to_string_no_filter ~meta:(Some meta) filt_src_ctx @@ -1801,8 +1834,9 @@ let match_ctx_with_target (config : config) (meta : Meta.meta) (loop_id : LoopId (* No mapping: this means that the borrow was mapped when we matched values (it doesn't come from a fresh abstraction) and because of this, it should actually be mapped to itself *) - sanity_check ( - BorrowId.InjSubst.find id src_to_tgt_maps.borrow_id_map = id) meta; + sanity_check + (BorrowId.InjSubst.find id src_to_tgt_maps.borrow_id_map = id) + meta; id | Some id -> id @@ -1833,7 +1867,8 @@ let match_ctx_with_target (config : config) (meta : Meta.meta) (loop_id : LoopId log#ldebug (lazy ("match_ctx_with_target: cf_introduce_loop_fp_abs: done:\n\ - - result ctx:\n" ^ eval_ctx_to_string ~meta:(Some meta) tgt_ctx)); + - result ctx:\n" + ^ eval_ctx_to_string ~meta:(Some meta) tgt_ctx)); (* Sanity check *) if !Config.sanity_checks then diff --git a/compiler/InterpreterPaths.ml b/compiler/InterpreterPaths.ml index 93ce0515..c386c2db 100644 --- a/compiler/InterpreterPaths.ml +++ b/compiler/InterpreterPaths.ml @@ -69,7 +69,8 @@ type projection_access = { TODO: use exceptions? *) -let rec access_projection (meta : Meta.meta) (access : projection_access) (ctx : eval_ctx) +let rec access_projection (meta : Meta.meta) (access : projection_access) + (ctx : eval_ctx) (* Function to (eventually) update the value we find *) (update : typed_value -> typed_value) (p : projection) (v : typed_value) : (eval_ctx * updated_read_value) path_access_result = @@ -86,10 +87,9 @@ let rec access_projection (meta : Meta.meta) (access : projection_access) (ctx : (lazy ("Not the same type:\n- nv.ty: " ^ show_ety nv.ty ^ "\n- v.ty: " ^ show_ety v.ty)); - craise - meta - "Assertion failed: new value doesn't have the same type as its \ - destination"); + craise meta + "Assertion failed: new value doesn't have the same type as its \ + destination"); Ok (ctx, { read = v; updated = nv }) | pe :: p' -> ( (* Match on the projection element and the value *) @@ -232,7 +232,9 @@ let rec access_projection (meta : Meta.meta) (access : projection_access) (ctx : to the fact that we need to reexplore the *whole* place (i.e, we mustn't ignore the current projection element *) if access.enter_shared_loans then - match access_projection meta access ctx update (pe :: p') sv with + match + access_projection meta access ctx update (pe :: p') sv + with | Error err -> Error err | Ok (ctx, res) -> let nv = @@ -301,8 +303,8 @@ let access_kind_to_projection_access (access : access_kind) : projection_access Note that we only access the value at the place, and do not check that the value is "well-formed" (for instance that it doesn't contain bottoms). *) -let try_read_place (meta : Meta.meta) (access : access_kind) (p : place) (ctx : eval_ctx) : - typed_value path_access_result = +let try_read_place (meta : Meta.meta) (access : access_kind) (p : place) + (ctx : eval_ctx) : typed_value path_access_result = let access = access_kind_to_projection_access access in (* The update function is the identity *) let update v = v in @@ -322,15 +324,15 @@ let try_read_place (meta : Meta.meta) (access : access_kind) (p : place) (ctx : craise meta "Unexpected environment update"); Ok read_value -let read_place (meta : Meta.meta) (access : access_kind) (p : place) (ctx : eval_ctx) : typed_value - = +let read_place (meta : Meta.meta) (access : access_kind) (p : place) + (ctx : eval_ctx) : typed_value = match try_read_place meta access p ctx with | Error e -> craise meta ("Unreachable: " ^ show_path_fail_kind e) | Ok v -> v (** Attempt to update the value at a given place *) -let try_write_place (meta : Meta.meta) (access : access_kind) (p : place) (nv : typed_value) - (ctx : eval_ctx) : eval_ctx path_access_result = +let try_write_place (meta : Meta.meta) (access : access_kind) (p : place) + (nv : typed_value) (ctx : eval_ctx) : eval_ctx path_access_result = let access = access_kind_to_projection_access access in (* The update function substitutes the value with the new value *) let update _ = nv in @@ -340,26 +342,28 @@ let try_write_place (meta : Meta.meta) (access : access_kind) (p : place) (nv : (* We ignore the read value *) Ok ctx -let write_place (meta : Meta.meta) (access : access_kind) (p : place) (nv : typed_value) - (ctx : eval_ctx) : eval_ctx = +let write_place (meta : Meta.meta) (access : access_kind) (p : place) + (nv : typed_value) (ctx : eval_ctx) : eval_ctx = match try_write_place meta access p nv ctx with | Error e -> craise meta ("Unreachable: " ^ show_path_fail_kind e) | Ok ctx -> ctx -let compute_expanded_bottom_adt_value (meta : Meta.meta) (ctx : eval_ctx) (def_id : TypeDeclId.id) - (opt_variant_id : VariantId.id option) (generics : generic_args) : - typed_value = +let compute_expanded_bottom_adt_value (meta : Meta.meta) (ctx : eval_ctx) + (def_id : TypeDeclId.id) (opt_variant_id : VariantId.id option) + (generics : generic_args) : typed_value = sanity_check (TypesUtils.generic_args_only_erased_regions generics) meta; (* Lookup the definition and check if it is an enumeration - it should be an enumeration if and only if the projection element is a field projection with *some* variant id. Retrieve the list of fields at the same time. *) let def = ctx_lookup_type_decl ctx def_id in - sanity_check (List.length generics.regions = List.length def.generics.regions) meta; + sanity_check + (List.length generics.regions = List.length def.generics.regions) + meta; (* Compute the field types *) let field_types = - AssociatedTypes.type_decl_get_inst_norm_field_etypes meta ctx def opt_variant_id - generics + AssociatedTypes.type_decl_get_inst_norm_field_etypes meta ctx def + opt_variant_id generics in (* Initialize the expanded value *) let fields = List.map (mk_bottom meta) field_types in @@ -367,7 +371,8 @@ let compute_expanded_bottom_adt_value (meta : Meta.meta) (ctx : eval_ctx) (def_i let ty = TAdt (TAdtId def_id, generics) in { value = av; ty } -let compute_expanded_bottom_tuple_value (meta : Meta.meta) (field_types : ety list) : typed_value = +let compute_expanded_bottom_tuple_value (meta : Meta.meta) + (field_types : ety list) : typed_value = (* Generate the field values *) let fields = List.map (mk_bottom meta) field_types in let v = VAdt { variant_id = None; field_values = fields } in @@ -396,9 +401,9 @@ let compute_expanded_bottom_tuple_value (meta : Meta.meta) (field_types : ety li about which variant we should project to, which is why we *can* set the variant index when writing one of its fields). *) -let expand_bottom_value_from_projection (meta : Meta.meta) (access : access_kind) (p : place) - (remaining_pes : int) (pe : projection_elem) (ty : ety) (ctx : eval_ctx) : - eval_ctx = +let expand_bottom_value_from_projection (meta : Meta.meta) + (access : access_kind) (p : place) (remaining_pes : int) + (pe : projection_elem) (ty : ety) (ctx : eval_ctx) : eval_ctx = (* Debugging *) log#ldebug (lazy @@ -426,7 +431,8 @@ let expand_bottom_value_from_projection (meta : Meta.meta) (access : access_kind | ( Field (ProjAdt (def_id, opt_variant_id), _), TAdt (TAdtId def_id', generics) ) -> sanity_check (def_id = def_id') meta; - compute_expanded_bottom_adt_value meta ctx def_id opt_variant_id generics + compute_expanded_bottom_adt_value meta ctx def_id opt_variant_id + generics (* Tuples *) | ( Field (ProjTuple arity, _), TAdt @@ -436,17 +442,16 @@ let expand_bottom_value_from_projection (meta : Meta.meta) (access : access_kind (* Generate the field values *) compute_expanded_bottom_tuple_value meta types | _ -> - craise - meta - ("Unreachable: " ^ show_projection_elem pe ^ ", " ^ show_ety ty) + craise meta + ("Unreachable: " ^ show_projection_elem pe ^ ", " ^ show_ety ty) in (* Update the context by inserting the expanded value at the proper place *) match try_write_place meta access p' nv ctx with | Ok ctx -> ctx | Error _ -> craise meta "Unreachable" -let rec update_ctx_along_read_place (config : config) (meta : Meta.meta) (access : access_kind) - (p : place) : cm_fun = +let rec update_ctx_along_read_place (config : config) (meta : Meta.meta) + (access : access_kind) (p : place) : cm_fun = fun cf ctx -> (* Attempt to read the place: if it fails, update the environment and retry *) match try_read_place meta access p ctx with @@ -456,7 +461,8 @@ let rec update_ctx_along_read_place (config : config) (meta : Meta.meta) (access match err with | FailSharedLoan bids -> end_borrows config meta bids | FailMutLoan bid -> end_borrow config meta bid - | FailReservedMutBorrow bid -> promote_reserved_mut_borrow config meta bid + | FailReservedMutBorrow bid -> + promote_reserved_mut_borrow config meta bid | FailSymbolic (i, sp) -> (* Expand the symbolic value *) let proj, _ = @@ -473,8 +479,8 @@ let rec update_ctx_along_read_place (config : config) (meta : Meta.meta) (access in comp cc (update_ctx_along_read_place config meta access p) cf ctx -let rec update_ctx_along_write_place (config : config) (meta : Meta.meta) (access : access_kind) - (p : place) : cm_fun = +let rec update_ctx_along_write_place (config : config) (meta : Meta.meta) + (access : access_kind) (p : place) : cm_fun = fun cf ctx -> (* Attempt to *read* (yes, *read*: we check the access to the place, and write to it later) the place: if it fails, update the environment and retry *) @@ -486,7 +492,8 @@ let rec update_ctx_along_write_place (config : config) (meta : Meta.meta) (acces match err with | FailSharedLoan bids -> end_borrows config meta bids | FailMutLoan bid -> end_borrow config meta bid - | FailReservedMutBorrow bid -> promote_reserved_mut_borrow config meta bid + | FailReservedMutBorrow bid -> + promote_reserved_mut_borrow config meta bid | FailSymbolic (_pe, sp) -> (* Expand the symbolic value *) expand_symbolic_value_no_branching config meta sp @@ -495,8 +502,8 @@ let rec update_ctx_along_write_place (config : config) (meta : Meta.meta) (acces (* Expand the {!Bottom} value *) fun cf ctx -> let ctx = - expand_bottom_value_from_projection meta access p remaining_pes pe ty - ctx + expand_bottom_value_from_projection meta access p remaining_pes + pe ty ctx in cf ctx | FailBorrow _ -> craise meta "Could not write to a borrow" @@ -507,8 +514,8 @@ let rec update_ctx_along_write_place (config : config) (meta : Meta.meta) (acces (** Small utility used to break control-flow *) exception UpdateCtx of cm_fun -let rec end_loans_at_place (config : config) (meta : Meta.meta) (access : access_kind) (p : place) - : cm_fun = +let rec end_loans_at_place (config : config) (meta : Meta.meta) + (access : access_kind) (p : place) : cm_fun = fun cf ctx -> (* Iterator to explore a value and update the context whenever we find * loans. @@ -562,7 +569,8 @@ let rec end_loans_at_place (config : config) (meta : Meta.meta) (access : access * a recursive call to reinspect the value *) comp cc (end_loans_at_place config meta access p) cf ctx -let drop_outer_loans_at_lplace (config : config) (meta : Meta.meta) (p : place) : cm_fun = +let drop_outer_loans_at_lplace (config : config) (meta : Meta.meta) (p : place) + : cm_fun = fun cf ctx -> (* Move the current value in the place outside of this place and into * a dummy variable *) @@ -610,13 +618,14 @@ let drop_outer_loans_at_lplace (config : config) (meta : Meta.meta) (p : place) (* Continue *) cc cf ctx -let prepare_lplace (config : config) (meta : Meta.meta) (p : place) (cf : typed_value -> m_fun) : - m_fun = +let prepare_lplace (config : config) (meta : Meta.meta) (p : place) + (cf : typed_value -> m_fun) : m_fun = fun ctx -> log#ldebug (lazy ("prepare_lplace:" ^ "\n- p: " ^ place_to_string ctx p - ^ "\n- Initial context:\n" ^ eval_ctx_to_string ~meta:(Some meta) ctx)); + ^ "\n- Initial context:\n" + ^ eval_ctx_to_string ~meta:(Some meta) ctx)); (* Access the place *) let access = Write in let cc = update_ctx_along_write_place config meta access p in diff --git a/compiler/InterpreterPaths.mli b/compiler/InterpreterPaths.mli index f1c481ca..260f07bf 100644 --- a/compiler/InterpreterPaths.mli +++ b/compiler/InterpreterPaths.mli @@ -13,13 +13,15 @@ type access_kind = Read | Write | Move updates the environment (by ending borrows, expanding symbolic values, etc.) until it manages to fully access the provided place. *) -val update_ctx_along_read_place : config -> Meta.meta -> access_kind -> place -> cm_fun +val update_ctx_along_read_place : + config -> Meta.meta -> access_kind -> place -> cm_fun (** Update the environment to be able to write to a place. See {!update_ctx_along_read_place}. *) -val update_ctx_along_write_place : config -> Meta.meta -> access_kind -> place -> cm_fun +val update_ctx_along_write_place : + config -> Meta.meta -> access_kind -> place -> cm_fun (** Read the value at a given place. @@ -40,7 +42,8 @@ val read_place : Meta.meta -> access_kind -> place -> eval_ctx -> typed_value the overwritten value contains borrows, loans, etc. and will simply overwrite it. *) -val write_place : Meta.meta -> access_kind -> place -> typed_value -> eval_ctx -> eval_ctx +val write_place : + Meta.meta -> access_kind -> place -> typed_value -> eval_ctx -> eval_ctx (** Compute an expanded tuple ⊥ value. @@ -96,4 +99,5 @@ val end_loans_at_place : config -> Meta.meta -> access_kind -> place -> cm_fun place. This value should not contain any outer loan (and we check it is the case). Note that this value is very likely to contain ⊥ subvalues. *) -val prepare_lplace : config -> Meta.meta -> place -> (typed_value -> m_fun) -> m_fun +val prepare_lplace : + config -> Meta.meta -> place -> (typed_value -> m_fun) -> m_fun diff --git a/compiler/InterpreterProjectors.ml b/compiler/InterpreterProjectors.ml index 809303ae..f8f99584 100644 --- a/compiler/InterpreterProjectors.ml +++ b/compiler/InterpreterProjectors.ml @@ -27,7 +27,8 @@ let rec apply_proj_borrows_on_shared_borrow (meta : Meta.meta) (ctx : eval_ctx) | VAdt adt, TAdt (id, generics) -> (* Retrieve the types of the fields *) let field_types = - Assoc.ctx_adt_value_get_inst_norm_field_rtypes meta ctx adt id generics + Assoc.ctx_adt_value_get_inst_norm_field_rtypes meta ctx adt id + generics in (* Project over the field values *) @@ -35,8 +36,8 @@ let rec apply_proj_borrows_on_shared_borrow (meta : Meta.meta) (ctx : eval_ctx) let proj_fields = List.map (fun (fv, fty) -> - apply_proj_borrows_on_shared_borrow meta ctx fresh_reborrow regions fv - fty) + apply_proj_borrows_on_shared_borrow meta ctx fresh_reborrow + regions fv fty) fields_types in List.concat proj_fields @@ -49,8 +50,8 @@ let rec apply_proj_borrows_on_shared_borrow (meta : Meta.meta) (ctx : eval_ctx) | VMutBorrow (bid, bv), RMut -> (* Apply the projection on the borrowed value *) let asb = - apply_proj_borrows_on_shared_borrow meta ctx fresh_reborrow regions - bv ref_ty + apply_proj_borrows_on_shared_borrow meta ctx fresh_reborrow + regions bv ref_ty in (bid, asb) | VSharedBorrow bid, RShared -> @@ -67,9 +68,8 @@ let rec apply_proj_borrows_on_shared_borrow (meta : Meta.meta) (ctx : eval_ctx) in (bid, asb) | VReservedMutBorrow _, _ -> - craise - meta - "Can't apply a proj_borrow over a reserved mutable borrow" + craise meta + "Can't apply a proj_borrow over a reserved mutable borrow" | _ -> craise meta "Unreachable" in let asb = @@ -84,14 +84,17 @@ let rec apply_proj_borrows_on_shared_borrow (meta : Meta.meta) (ctx : eval_ctx) | VLoan _, _ -> craise meta "Unreachable" | VSymbolic s, _ -> (* Check that the projection doesn't contain ended regions *) - sanity_check (not (projections_intersect meta s.sv_ty ctx.ended_regions ty regions)) meta; + sanity_check + (not + (projections_intersect meta s.sv_ty ctx.ended_regions ty regions)) + meta; [ AsbProjReborrows (s, ty) ] | _ -> craise meta "Unreachable" -let rec apply_proj_borrows (meta : Meta.meta) (check_symbolic_no_ended : bool) (ctx : eval_ctx) - (fresh_reborrow : BorrowId.id -> BorrowId.id) (regions : RegionId.Set.t) - (ancestors_regions : RegionId.Set.t) (v : typed_value) (ty : rty) : - typed_avalue = +let rec apply_proj_borrows (meta : Meta.meta) (check_symbolic_no_ended : bool) + (ctx : eval_ctx) (fresh_reborrow : BorrowId.id -> BorrowId.id) + (regions : RegionId.Set.t) (ancestors_regions : RegionId.Set.t) + (v : typed_value) (ty : rty) : typed_avalue = (* Sanity check - TODO: move this elsewhere (here we perform the check at every * recursive call which is a bit overkill...) *) let ety = Substitute.erase_regions ty in @@ -105,15 +108,16 @@ let rec apply_proj_borrows (meta : Meta.meta) (check_symbolic_no_ended : bool) ( | VAdt adt, TAdt (id, generics) -> (* Retrieve the types of the fields *) let field_types = - Assoc.ctx_adt_value_get_inst_norm_field_rtypes meta ctx adt id generics + Assoc.ctx_adt_value_get_inst_norm_field_rtypes meta ctx adt id + generics in (* Project over the field values *) let fields_types = List.combine adt.field_values field_types in let proj_fields = List.map (fun (fv, fty) -> - apply_proj_borrows meta check_symbolic_no_ended ctx fresh_reborrow - regions ancestors_regions fv fty) + apply_proj_borrows meta check_symbolic_no_ended ctx + fresh_reborrow regions ancestors_regions fv fty) fields_types in AAdt { variant_id = adt.variant_id; field_values = proj_fields } @@ -148,10 +152,8 @@ let rec apply_proj_borrows (meta : Meta.meta) (check_symbolic_no_ended : bool) ( *) ASharedBorrow bid | VReservedMutBorrow _, _ -> - craise - meta - "Can't apply a proj_borrow over a reserved mutable \ - borrow" + craise meta + "Can't apply a proj_borrow over a reserved mutable borrow" | _ -> craise meta "Unreachable" in ABorrow bc @@ -182,16 +184,14 @@ let rec apply_proj_borrows (meta : Meta.meta) (check_symbolic_no_ended : bool) ( match sv with | _, Concrete (VSharedLoan (_, sv)) | _, Abstract (ASharedLoan (_, sv, _)) -> - apply_proj_borrows_on_shared_borrow meta ctx fresh_reborrow - regions sv ref_ty + apply_proj_borrows_on_shared_borrow meta ctx + fresh_reborrow regions sv ref_ty | _ -> craise meta "Unexpected" in AProjSharedBorrow asb | VReservedMutBorrow _, _ -> - craise - meta - "Can't apply a proj_borrow over a reserved mutable \ - borrow" + craise meta + "Can't apply a proj_borrow over a reserved mutable borrow" | _ -> craise meta "Unreachable" in ABorrow bc @@ -199,20 +199,21 @@ let rec apply_proj_borrows (meta : Meta.meta) (check_symbolic_no_ended : bool) ( | VSymbolic s, _ -> (* Check that the projection doesn't contain already ended regions, * if necessary *) - if check_symbolic_no_ended then ( - let ty1 = s.sv_ty in - let rset1 = ctx.ended_regions in - let ty2 = ty in - let rset2 = regions in - log#ldebug - (lazy - ("projections_intersect:" ^ "\n- ty1: " ^ ty_to_string ctx ty1 - ^ "\n- rset1: " - ^ RegionId.Set.to_string None rset1 - ^ "\n- ty2: " ^ ty_to_string ctx ty2 ^ "\n- rset2: " - ^ RegionId.Set.to_string None rset2 - ^ "\n")); - sanity_check (not (projections_intersect meta ty1 rset1 ty2 rset2))) meta; + if check_symbolic_no_ended then + (let ty1 = s.sv_ty in + let rset1 = ctx.ended_regions in + let ty2 = ty in + let rset2 = regions in + log#ldebug + (lazy + ("projections_intersect:" ^ "\n- ty1: " ^ ty_to_string ctx ty1 + ^ "\n- rset1: " + ^ RegionId.Set.to_string None rset1 + ^ "\n- ty2: " ^ ty_to_string ctx ty2 ^ "\n- rset2: " + ^ RegionId.Set.to_string None rset2 + ^ "\n")); + sanity_check (not (projections_intersect meta ty1 rset1 ty2 rset2))) + meta; ASymbolic (AProjBorrows (s, ty)) | _ -> log#lerror @@ -224,8 +225,8 @@ let rec apply_proj_borrows (meta : Meta.meta) (check_symbolic_no_ended : bool) ( in { value; ty } -let symbolic_expansion_non_borrow_to_value (meta : Meta.meta) (sv : symbolic_value) - (see : symbolic_expansion) : typed_value = +let symbolic_expansion_non_borrow_to_value (meta : Meta.meta) + (sv : symbolic_value) (see : symbolic_expansion) : typed_value = let ty = Subst.erase_regions sv.sv_ty in let value = match see with @@ -240,8 +241,8 @@ let symbolic_expansion_non_borrow_to_value (meta : Meta.meta) (sv : symbolic_val in { value; ty } -let symbolic_expansion_non_shared_borrow_to_value (meta : Meta.meta) (sv : symbolic_value) - (see : symbolic_expansion) : typed_value = +let symbolic_expansion_non_shared_borrow_to_value (meta : Meta.meta) + (sv : symbolic_value) (see : symbolic_expansion) : typed_value = match see with | SeMutRef (bid, bv) -> let ty = Subst.erase_regions sv.sv_ty in @@ -256,9 +257,9 @@ let symbolic_expansion_non_shared_borrow_to_value (meta : Meta.meta) (sv : symbo TODO: detailed comments. See [apply_proj_borrows] *) -let apply_proj_loans_on_symbolic_expansion (meta : Meta.meta) (regions : RegionId.Set.t) - (ancestors_regions : RegionId.Set.t) (see : symbolic_expansion) - (original_sv_ty : rty) : typed_avalue = +let apply_proj_loans_on_symbolic_expansion (meta : Meta.meta) + (regions : RegionId.Set.t) (ancestors_regions : RegionId.Set.t) + (see : symbolic_expansion) (original_sv_ty : rty) : typed_avalue = (* Sanity check: if we have a proj_loans over a symbolic value, it should * contain regions which we will project *) sanity_check (ty_has_regions_in_set regions original_sv_ty) meta; @@ -332,8 +333,8 @@ let apply_proj_loans_on_symbolic_expansion (meta : Meta.meta) (regions : RegionI borrows - easy - and mutable borrows - in this case, we reborrow the whole borrow: [mut_borrow ... ~~> shared_loan {...} (mut_borrow ...)]). *) -let apply_reborrows (meta : Meta.meta) (reborrows : (BorrowId.id * BorrowId.id) list) - (ctx : eval_ctx) : eval_ctx = +let apply_reborrows (meta : Meta.meta) + (reborrows : (BorrowId.id * BorrowId.id) list) (ctx : eval_ctx) : eval_ctx = (* This is a bit brutal, but whenever we insert a reborrow, we remove * it from the list. This allows us to check that all the reborrows were * applied before returning. @@ -468,7 +469,8 @@ let apply_reborrows (meta : Meta.meta) (reborrows : (BorrowId.id * BorrowId.id) (* Return *) ctx -let prepare_reborrows (config : config) (meta : Meta.meta) (allow_reborrows : bool) : +let prepare_reborrows (config : config) (meta : Meta.meta) + (allow_reborrows : bool) : (BorrowId.id -> BorrowId.id) * (eval_ctx -> eval_ctx) = let reborrows : (BorrowId.id * BorrowId.id) list ref = ref [] in (* The function to generate and register fresh reborrows *) @@ -492,9 +494,10 @@ let prepare_reborrows (config : config) (meta : Meta.meta) (allow_reborrows : bo (fresh_reborrow, apply_registered_reborrows) (** [ty] shouldn't have erased regions *) -let apply_proj_borrows_on_input_value (config : config) (meta : Meta.meta) (ctx : eval_ctx) - (regions : RegionId.Set.t) (ancestors_regions : RegionId.Set.t) - (v : typed_value) (ty : rty) : eval_ctx * typed_avalue = +let apply_proj_borrows_on_input_value (config : config) (meta : Meta.meta) + (ctx : eval_ctx) (regions : RegionId.Set.t) + (ancestors_regions : RegionId.Set.t) (v : typed_value) (ty : rty) : + eval_ctx * typed_avalue = cassert (ty_is_rty ty) meta "TODO: error message"; let check_symbolic_no_ended = true in let allow_reborrows = true in diff --git a/compiler/InterpreterProjectors.mli b/compiler/InterpreterProjectors.mli index 64ad1b29..17569ac8 100644 --- a/compiler/InterpreterProjectors.mli +++ b/compiler/InterpreterProjectors.mli @@ -15,7 +15,12 @@ open Contexts [original_sv_ty]: shouldn't have erased regions *) val apply_proj_loans_on_symbolic_expansion : - Meta.meta -> RegionId.Set.t -> RegionId.Set.t -> symbolic_expansion -> rty -> typed_avalue + Meta.meta -> + RegionId.Set.t -> + RegionId.Set.t -> + symbolic_expansion -> + rty -> + typed_avalue (** Convert a symbolic expansion *which is not a borrow* to a value *) val symbolic_expansion_non_borrow_to_value : @@ -28,7 +33,7 @@ val symbolic_expansion_non_borrow_to_value : during a symbolic expansion. *) val symbolic_expansion_non_shared_borrow_to_value : - Meta.meta -> symbolic_value -> symbolic_expansion -> typed_value + Meta.meta -> symbolic_value -> symbolic_expansion -> typed_value (** Auxiliary function to prepare reborrowing operations (used when applying projectors). @@ -43,7 +48,10 @@ val symbolic_expansion_non_shared_borrow_to_value : - [allow_reborrows] *) val prepare_reborrows : - config -> Meta.meta -> bool -> (BorrowId.id -> BorrowId.id) * (eval_ctx -> eval_ctx) + config -> + Meta.meta -> + bool -> + (BorrowId.id -> BorrowId.id) * (eval_ctx -> eval_ctx) (** Apply (and reduce) a projector over borrows to an avalue. We use this for instance to spread the borrows present in the inputs diff --git a/compiler/InterpreterStatements.ml b/compiler/InterpreterStatements.ml index a872f24a..fa7bbc51 100644 --- a/compiler/InterpreterStatements.ml +++ b/compiler/InterpreterStatements.ml @@ -24,7 +24,7 @@ let drop_value (config : config) (meta : Meta.meta) (p : place) : cm_fun = log#ldebug (lazy ("drop_value: place: " ^ place_to_string ctx p ^ "\n- Initial context:\n" - ^ eval_ctx_to_string ~meta:(Some meta) ctx)); + ^ eval_ctx_to_string ~meta:(Some meta) ctx)); (* Note that we use [Write], not [Move]: we allow to drop values *below* borrows *) let access = Write in (* First make sure we can access the place, by ending loans or expanding @@ -45,7 +45,7 @@ let drop_value (config : config) (meta : Meta.meta) (p : place) : cm_fun = log#ldebug (lazy ("drop_value: place: " ^ place_to_string ctx p ^ "\n- Final context:\n" - ^ eval_ctx_to_string ~meta:(Some meta) ctx)); + ^ eval_ctx_to_string ~meta:(Some meta) ctx)); cf ctx in (* Compose and apply *) @@ -58,7 +58,8 @@ let push_dummy_var (vid : DummyVarId.id) (v : typed_value) : cm_fun = cf ctx (** Remove a dummy variable from the environment *) -let remove_dummy_var (meta : Meta.meta) (vid : DummyVarId.id) (cf : typed_value -> m_fun) : m_fun = +let remove_dummy_var (meta : Meta.meta) (vid : DummyVarId.id) + (cf : typed_value -> m_fun) : m_fun = fun ctx -> let ctx, v = ctx_remove_dummy_var meta ctx vid in cf v ctx @@ -94,7 +95,8 @@ let push_vars (meta : Meta.meta) (vars : (var * typed_value) list) : cm_fun = dummy variable and putting in its destination (after having checked that preparing the destination didn't introduce ⊥). *) -let assign_to_place (config : config) (meta : Meta.meta) (rv : typed_value) (p : place) : cm_fun = +let assign_to_place (config : config) (meta : Meta.meta) (rv : typed_value) + (p : place) : cm_fun = fun cf ctx -> log#ldebug (lazy @@ -119,7 +121,9 @@ let assign_to_place (config : config) (meta : Meta.meta) (rv : typed_value) (p : let ctx = ctx_push_dummy_var ctx dest_vid mv in (* Write to the destination *) (* Checks - maybe the bookkeeping updated the rvalue and introduced bottoms *) - exec_assert (not (bottom_in_value ctx.ended_regions rv)) meta "The value to move contains bottom"; + exec_assert + (not (bottom_in_value ctx.ended_regions rv)) + meta "The value to move contains bottom"; (* Update the destination *) let ctx = write_place meta Write p rv ctx in (* Debug *) @@ -136,8 +140,8 @@ let assign_to_place (config : config) (meta : Meta.meta) (rv : typed_value) (p : comp cc move_dest cf ctx (** Evaluate an assertion, when the scrutinee is not symbolic *) -let eval_assertion_concrete (config : config) (meta : Meta.meta) (assertion : assertion) : - st_cm_fun = +let eval_assertion_concrete (config : config) (meta : Meta.meta) + (assertion : assertion) : st_cm_fun = fun cf ctx -> (* There won't be any symbolic expansions: fully evaluate the operand *) let eval_op = eval_operand config meta assertion.cond in @@ -148,8 +152,9 @@ let eval_assertion_concrete (config : config) (meta : Meta.meta) (assertion : as (* Branch *) if b = assertion.expected then cf Unit ctx else cf Panic ctx | _ -> - craise - meta ("Expected a boolean, got: " ^ typed_value_to_string ~meta:(Some meta) ctx v) + craise meta + ("Expected a boolean, got: " + ^ typed_value_to_string ~meta:(Some meta) ctx v) in (* Compose and apply *) comp eval_op eval_assert cf ctx @@ -160,7 +165,8 @@ let eval_assertion_concrete (config : config) (meta : Meta.meta) (assertion : as a call to [assert ...] then continue in the success branch (and thus expand the boolean to [true]). *) -let eval_assertion (config : config) (meta : Meta.meta) (assertion : assertion) : st_cm_fun = +let eval_assertion (config : config) (meta : Meta.meta) (assertion : assertion) + : st_cm_fun = fun cf ctx -> (* Evaluate the operand *) let eval_op = eval_operand config meta assertion.cond in @@ -178,23 +184,24 @@ let eval_assertion (config : config) (meta : Meta.meta) (assertion : assertion) (* Delegate to the concrete evaluation function *) eval_assertion_concrete config meta assertion cf ctx | VSymbolic sv -> - sanity_check(config.mode = SymbolicMode) meta; + sanity_check (config.mode = SymbolicMode) meta; sanity_check (sv.sv_ty = TLiteral TBool) meta; (* 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 meta sv (SeLiteral (VBool true)) - ctx + apply_symbolic_expansion_non_borrow config meta sv + (SeLiteral (VBool true)) ctx in (* Continue *) let expr = cf Unit ctx in (* Add the synthesized assertion *) S.synthesize_assertion ctx v expr | _ -> - craise - meta ("Expected a boolean, got: " ^ typed_value_to_string ~meta:(Some meta) ctx v) + craise meta + ("Expected a boolean, got: " + ^ typed_value_to_string ~meta:(Some meta) ctx v) in (* Compose and apply *) comp eval_op eval_assert cf ctx @@ -210,15 +217,16 @@ let eval_assertion (config : config) (meta : Meta.meta) (assertion : assertion) a variant with all its fields set to {!Bottom}. For instance, something like: [Cons Bottom Bottom]. *) -let set_discriminant (config : config) (meta : Meta.meta) (p : place) (variant_id : VariantId.id) : - st_cm_fun = +let set_discriminant (config : config) (meta : Meta.meta) (p : place) + (variant_id : VariantId.id) : st_cm_fun = fun cf ctx -> log#ldebug (lazy ("set_discriminant:" ^ "\n- p: " ^ place_to_string ctx p ^ "\n- variant id: " ^ VariantId.to_string variant_id - ^ "\n- initial context:\n" ^ eval_ctx_to_string ~meta:(Some meta) ctx)); + ^ "\n- initial context:\n" + ^ eval_ctx_to_string ~meta:(Some meta) ctx)); (* Access the value *) let access = Write in let cc = update_ctx_along_read_place config meta access p in @@ -253,8 +261,8 @@ let set_discriminant (config : config) (meta : Meta.meta) (p : place) (variant_i let bottom_v = match type_id with | TAdtId def_id -> - compute_expanded_bottom_adt_value meta ctx def_id (Some variant_id) - generics + compute_expanded_bottom_adt_value meta ctx def_id + (Some variant_id) generics | _ -> craise meta "Unreachable" in assign_to_place config meta bottom_v p (cf Unit) ctx @@ -269,8 +277,7 @@ let set_discriminant (config : config) (meta : Meta.meta) (p : place) (variant_i * or reset an already initialized value, really. *) craise meta "Unexpected value" | _, (VAdt _ | VBottom) -> craise meta "Inconsistent state" - | _, (VLiteral _ | VBorrow _ | VLoan _) -> - craise meta "Unexpected value" + | _, (VLiteral _ | VBorrow _ | VLoan _) -> craise meta "Unexpected value" in (* Compose and apply *) comp cc update_value cf ctx @@ -285,8 +292,8 @@ let push_frame : cm_fun = fun cf ctx -> cf (ctx_push_frame ctx) (** Small helper: compute the type of the return value for a specific instantiation of an assumed function. *) -let get_assumed_function_return_type (meta : Meta.meta) (ctx : eval_ctx) (fid : assumed_fun_id) - (generics : generic_args) : ety = +let get_assumed_function_return_type (meta : Meta.meta) (ctx : eval_ctx) + (fid : assumed_fun_id) (generics : generic_args) : ety = sanity_check (generics.trait_refs = []) meta; (* [Box::free] has a special treatment *) match fid with @@ -311,8 +318,8 @@ let get_assumed_function_return_type (meta : Meta.meta) (ctx : eval_ctx) (fid : in AssociatedTypes.ctx_normalize_erase_ty meta ctx ty -let move_return_value (config : config) (meta : Meta.meta) (pop_return_value : bool) - (cf : typed_value option -> m_fun) : m_fun = +let move_return_value (config : config) (meta : Meta.meta) + (pop_return_value : bool) (cf : typed_value option -> m_fun) : m_fun = fun ctx -> if pop_return_value then let ret_vid = VarId.zero in @@ -354,7 +361,9 @@ let pop_frame (config : config) (meta : Meta.meta) (pop_return_value : bool) match ret_value with | None -> () | Some ret_value -> - sanity_check (not (bottom_in_value ctx.ended_regions ret_value)) meta) + sanity_check + (not (bottom_in_value ctx.ended_regions ret_value)) + meta) in (* Drop the outer *loans* we find in the local variables *) @@ -377,7 +386,7 @@ let pop_frame (config : config) (meta : Meta.meta) (pop_return_value : bool) log#ldebug (lazy ("pop_frame: after dropping outer loans in local variables:\n" - ^ eval_ctx_to_string ~meta:(Some meta) ctx))) + ^ eval_ctx_to_string ~meta:(Some meta) ctx))) in (* Pop the frame - we remove the [Frame] delimiter, and reintroduce all @@ -402,7 +411,8 @@ let pop_frame (config : config) (meta : Meta.meta) (pop_return_value : bool) comp cc cf_pop cf ctx (** Pop the current frame and assign the returned value to its destination. *) -let pop_frame_assign (config : config) (meta : Meta.meta) (dest : place) : cm_fun = +let pop_frame_assign (config : config) (meta : Meta.meta) (dest : place) : + cm_fun = let cf_pop = pop_frame config meta true in let cf_assign cf ret_value : m_fun = assign_to_place config meta (Option.get ret_value) dest cf @@ -410,7 +420,8 @@ let pop_frame_assign (config : config) (meta : Meta.meta) (dest : place) : cm_fu comp cf_pop cf_assign (** Auxiliary function - see {!eval_assumed_function_call} *) -let eval_box_new_concrete (config : config) (meta : Meta.meta) (generics : generic_args) : cm_fun = +let eval_box_new_concrete (config : config) (meta : Meta.meta) + (generics : generic_args) : cm_fun = fun cf ctx -> (* Check and retrieve the arguments *) match @@ -477,9 +488,12 @@ let eval_box_free (config : config) (meta : Meta.meta) (generics : generic_args) match (generics.regions, generics.types, generics.const_generics, args) with | [], [ boxed_ty ], [], [ Move input_box_place ] -> (* Required type checking *) - let input_box = InterpreterPaths.read_place meta Write input_box_place ctx in + let input_box = + InterpreterPaths.read_place meta Write input_box_place ctx + in (let input_ty = ty_get_box input_box.ty in - sanity_check (input_ty = boxed_ty)) meta; + sanity_check (input_ty = boxed_ty)) + meta; (* Drop the value *) let cc = drop_value config meta input_box_place in @@ -492,8 +506,8 @@ let eval_box_free (config : config) (meta : Meta.meta) (generics : generic_args) | _ -> craise meta "Inconsistent state" (** Evaluate a non-local function call in concrete mode *) -let eval_assumed_function_call_concrete (config : config) (meta : Meta.meta) (fid : assumed_fun_id) - (call : call) : cm_fun = +let eval_assumed_function_call_concrete (config : config) (meta : Meta.meta) + (fid : assumed_fun_id) (call : call) : cm_fun = let args = call.args in let dest = call.dest in match call.func with @@ -504,7 +518,7 @@ let eval_assumed_function_call_concrete (config : config) (meta : Meta.meta) (fi let generics = func.generics in (* Sanity check: we don't fully handle the const generic vars environment in concrete mode yet *) - sanity_check (generics.const_generics = []) meta; + sanity_check (generics.const_generics = []) meta; (* There are two cases (and this is extremely annoying): - the function is not box_free - the function is box_free @@ -535,7 +549,9 @@ let eval_assumed_function_call_concrete (config : config) (meta : Meta.meta) (fi (* Create and push the return variable *) let ret_vid = VarId.zero in - let ret_ty = get_assumed_function_return_type meta ctx fid generics in + let ret_ty = + get_assumed_function_return_type meta ctx fid generics + in let ret_var = mk_var ret_vid (Some "@return") ret_ty in let cc = comp cc (push_uninitialized_var meta ret_var) in @@ -728,8 +744,8 @@ let create_push_abstractions_from_abs_region_groups which means that whenever we call a provided trait method, we do not refer to a trait clause but directly to the method provided in the trait declaration. *) -let eval_transparent_function_call_symbolic_inst (meta : Meta.meta) (call : call) (ctx : eval_ctx) - : +let eval_transparent_function_call_symbolic_inst (meta : Meta.meta) + (call : call) (ctx : eval_ctx) : fun_id_or_trait_method_ref * generic_args * (generic_args * trait_instance_id) option @@ -823,7 +839,9 @@ let eval_transparent_function_call_symbolic_inst (meta : Meta.meta) (call : call | None -> (* If not found, lookup the methods provided by the trait *declaration* (remember: for now, we forbid overriding provided methods) *) - cassert (trait_impl.provided_methods = []) meta "Overriding provided methods is currently forbidden"; + cassert + (trait_impl.provided_methods = []) + meta "Overriding provided methods is currently forbidden"; let trait_decl = ctx_lookup_trait_decl ctx trait_ref.trait_decl_ref.trait_decl_id @@ -912,8 +930,8 @@ let eval_transparent_function_call_symbolic_inst (meta : Meta.meta) (call : call in let tr_self = TraitRef trait_ref in let inst_sg = - instantiate_fun_sig meta ctx generics tr_self method_def.signature - regions_hierarchy + instantiate_fun_sig meta ctx generics tr_self + method_def.signature regions_hierarchy in ( func.func, func.generics, @@ -930,7 +948,9 @@ let rec eval_statement (config : config) (st : statement) : st_cm_fun = (lazy ("\n**About to evaluate statement**: [\n" ^ statement_to_string_with_tab ctx st - ^ "\n]\n\n**Context**:\n" ^ eval_ctx_to_string ~meta:(Some st.meta) ctx ^ "\n\n")); + ^ "\n]\n\n**Context**:\n" + ^ eval_ctx_to_string ~meta:(Some st.meta) ctx + ^ "\n\n")); (* Take a snapshot of the current context for the purpose of generating pretty names *) let cc = S.cf_save_snapshot in @@ -963,11 +983,14 @@ let rec eval_statement (config : config) (st : statement) : st_cm_fun = log#ldebug (lazy ("about to assign to place: " ^ place_to_string ctx p - ^ "\n- Context:\n" ^ eval_ctx_to_string ~meta:(Some st.meta) ctx)); + ^ "\n- Context:\n" + ^ eval_ctx_to_string ~meta:(Some st.meta) ctx)); match res with | Error EPanic -> cf Panic ctx | Ok rv -> ( - let expr = assign_to_place config st.meta rv p (cf Unit) ctx in + let expr = + assign_to_place config st.meta rv p (cf Unit) ctx + in (* Update the synthesized AST - here we store meta-information. * We do it only in specific cases (it is not always useful, and * also it can lead to issues - for instance, if we borrow a @@ -983,8 +1006,9 @@ let rec eval_statement (config : config) (st : statement) : st_cm_fun = | Some rp -> Some (S.mk_mplace st.meta rp ctx) | None -> None in - S.synthesize_assignment ctx (S.mk_mplace st.meta p ctx) rv rp expr - ) + S.synthesize_assignment ctx + (S.mk_mplace st.meta p ctx) + rv rp expr) in (* Compose and apply *) @@ -1033,11 +1057,14 @@ and eval_global (config : config) (dest : place) (gid : GlobalDeclId.id) (* Treat the evaluation of the global as a call to the global body *) let func = { func = FunId (FRegular global.body); generics } in let call = { func = FnOpRegular func; args = []; dest } in - (eval_transparent_function_call_concrete config global.meta global.body call) cf ctx + (eval_transparent_function_call_concrete config global.meta global.body + call) + cf ctx | SymbolicMode -> (* Generate a fresh symbolic value. In the translation, this fresh symbolic value will be * defined as equal to the value of the global (see {!S.synthesize_global_eval}). *) - cassert (ty_no_regions global.ty) global.meta "Const globals should not contain regions"; + cassert (ty_no_regions global.ty) global.meta + "Const globals should not contain regions"; (* Instantiate the type *) (* There shouldn't be any reference to Self *) let tr_self : trait_instance_id = UnknownTrait __FUNCTION__ in @@ -1051,13 +1078,16 @@ and eval_global (config : config) (dest : place) (gid : GlobalDeclId.id) in let sval = mk_fresh_symbolic_value global.meta ty in let cc = - assign_to_place config global.meta (mk_typed_value_from_symbolic_value sval) dest + assign_to_place config global.meta + (mk_typed_value_from_symbolic_value sval) + dest in let e = cc (cf Unit) ctx in S.synthesize_global_eval gid generics sval e (** Evaluate a switch *) -and eval_switch (config : config) (meta : Meta.meta) (switch : switch) : st_cm_fun = +and eval_switch (config : config) (meta : Meta.meta) (switch : switch) : + st_cm_fun = fun cf ctx -> (* We evaluate the operand in two steps: * first we prepare it, then we check if its value is concrete or @@ -1151,7 +1181,8 @@ and eval_switch (config : config) (meta : Meta.meta) (switch : switch) : st_cm_f let access = Read in let expand_prim_copy = false in let cf_read_p cf : m_fun = - access_rplace_reorganize_and_read config meta expand_prim_copy access p cf + access_rplace_reorganize_and_read config meta expand_prim_copy access + p cf in (* Match on the value *) let cf_match (cf : st_m_fun) (p_v : typed_value) : m_fun = @@ -1174,7 +1205,8 @@ and eval_switch (config : config) (meta : Meta.meta) (switch : switch) : st_cm_f | VSymbolic sv -> (* Expand the symbolic value - may lead to branching *) let cf_expand = - expand_symbolic_adt config meta sv (Some (S.mk_mplace meta p ctx)) + expand_symbolic_adt config meta sv + (Some (S.mk_mplace meta p ctx)) in (* Re-evaluate the switch - the value is not symbolic anymore, which means we will go to the other branch *) @@ -1188,7 +1220,8 @@ and eval_switch (config : config) (meta : Meta.meta) (switch : switch) : st_cm_f cf_match cf ctx (** Evaluate a function call (auxiliary helper for [eval_statement]) *) -and eval_function_call (config : config) (meta : Meta.meta) (call : call) : st_cm_fun = +and eval_function_call (config : config) (meta : Meta.meta) (call : call) : + st_cm_fun = (* There are several cases: - this is a local function, in which case we execute its body - this is an assumed function, in which case there is a special treatment @@ -1198,7 +1231,8 @@ and eval_function_call (config : config) (meta : Meta.meta) (call : call) : st_c | ConcreteMode -> eval_function_call_concrete config meta call | SymbolicMode -> eval_function_call_symbolic config meta call -and eval_function_call_concrete (config : config) (meta : Meta.meta) (call : call) : st_cm_fun = +and eval_function_call_concrete (config : config) (meta : Meta.meta) + (call : call) : st_cm_fun = fun cf ctx -> match call.func with | FnOpMove _ -> craise meta "Closures are not supported yet" @@ -1214,7 +1248,8 @@ and eval_function_call_concrete (config : config) (meta : Meta.meta) (call : cal eval_assumed_function_call_concrete config meta fid call (cf Unit) ctx | TraitMethod _ -> craise meta "Unimplemented") -and eval_function_call_symbolic (config : config) (meta : Meta.meta) (call : call) : st_cm_fun = +and eval_function_call_symbolic (config : config) (meta : Meta.meta) + (call : call) : st_cm_fun = match call.func with | FnOpMove _ -> craise meta "Closures are not supported yet" | FnOpRegular func -> ( @@ -1235,7 +1270,7 @@ and eval_transparent_function_call_concrete (config : config) (meta : Meta.meta) let generics = func.generics in (* Sanity check: we don't fully handle the const generic vars environment in concrete mode yet *) - sanity_check (generics.const_generics = []) meta; + sanity_check (generics.const_generics = []) meta; fun cf ctx -> (* Retrieve the (correctly instantiated) body *) let def = ctx_lookup_fun_decl ctx fid in @@ -1243,14 +1278,14 @@ and eval_transparent_function_call_concrete (config : config) (meta : Meta.meta) let body = match def.body with | None -> - craise - meta - ("Can't evaluate a call to an opaque function: " - ^ name_to_string ctx def.name) + craise meta + ("Can't evaluate a call to an opaque function: " + ^ name_to_string ctx def.name) | Some body -> body in (* TODO: we need to normalize the types if we want to correctly support traits *) - cassert (generics.trait_refs = []) body.meta "Traits are not supported yet in concrete mode"; + cassert (generics.trait_refs = []) body.meta + "Traits are not supported yet in concrete mode"; (* There shouldn't be any reference to Self *) let tr_self = UnknownTrait __FUNCTION__ in let subst = @@ -1259,7 +1294,7 @@ and eval_transparent_function_call_concrete (config : config) (meta : Meta.meta) let locals, body_st = Subst.fun_body_substitute_in_body subst body in (* Evaluate the input operands *) - sanity_check(List.length args = body.arg_count) body.meta; + sanity_check (List.length args = body.arg_count) body.meta; let cc = eval_operands config body.meta args in (* Push a frame delimiter - we use {!comp_transmit} to transmit the result @@ -1279,7 +1314,8 @@ and eval_transparent_function_call_concrete (config : config) (meta : Meta.meta) in let cc = - comp_transmit cc (push_var meta ret_var (mk_bottom meta ret_var.var_ty)) + comp_transmit cc + (push_var meta ret_var (mk_bottom meta ret_var.var_ty)) in (* 2. Push the input values *) @@ -1315,14 +1351,16 @@ and eval_transparent_function_call_concrete (config : config) (meta : Meta.meta) cc cf ctx (** Evaluate a local (i.e., non-assumed) function call in symbolic mode *) -and eval_transparent_function_call_symbolic (config : config) (meta : Meta.meta) (call : call) : - st_cm_fun = +and eval_transparent_function_call_symbolic (config : config) (meta : Meta.meta) + (call : call) : st_cm_fun = fun cf ctx -> let func, generics, trait_method_generics, def, regions_hierarchy, inst_sg = eval_transparent_function_call_symbolic_inst meta call ctx in (* Sanity check *) - sanity_check (List.length call.args = List.length def.signature.inputs) def.meta; + sanity_check + (List.length call.args = List.length def.signature.inputs) + def.meta; (* Evaluate the function call *) eval_function_call_symbolic_from_inst_sig config def.meta func def.signature regions_hierarchy inst_sg generics trait_method_generics call.args call.dest @@ -1339,8 +1377,8 @@ and eval_transparent_function_call_symbolic (config : config) (meta : Meta.meta) overriding them. We treat them as regular method, which take an additional trait ref as input. *) -and eval_function_call_symbolic_from_inst_sig (config : config) (meta : Meta.meta) - (fid : fun_id_or_trait_method_ref) (sg : fun_sig) +and eval_function_call_symbolic_from_inst_sig (config : config) + (meta : Meta.meta) (fid : fun_id_or_trait_method_ref) (sg : fun_sig) (regions_hierarchy : region_var_groups) (inst_sg : inst_fun_sig) (generics : generic_args) (trait_method_generics : (generic_args * trait_instance_id) option) @@ -1365,7 +1403,9 @@ and eval_function_call_symbolic_from_inst_sig (config : config) (meta : Meta.met let ret_av regions = mk_aproj_loans_value_from_symbolic_value regions ret_spc in - let args_places = List.map (fun p -> S.mk_opt_place_from_op meta p ctx) args in + let args_places = + List.map (fun p -> S.mk_opt_place_from_op meta p ctx) args + in let dest_place = Some (S.mk_mplace meta dest ctx) in (* Evaluate the input operands *) @@ -1378,20 +1418,22 @@ and eval_function_call_symbolic_from_inst_sig (config : config) (meta : Meta.met let args_with_rtypes = List.combine args inst_sg.inputs in (* Check the type of the input arguments *) - cassert ( - List.for_all - (fun ((arg, rty) : typed_value * rty) -> - arg.ty = Subst.erase_regions rty) - args_with_rtypes) meta "TODO: Error message"; + cassert + (List.for_all + (fun ((arg, rty) : typed_value * rty) -> + arg.ty = Subst.erase_regions rty) + args_with_rtypes) + meta "TODO: Error message"; (* Check that the input arguments don't contain symbolic values that can't * be fed to functions (i.e., symbolic values output from function return * values and which contain borrows of borrows can't be used as function * inputs *) - sanity_check ( - List.for_all - (fun arg -> - not (value_has_ret_symbolic_value_with_borrow_under_mut ctx arg)) - args) meta; + sanity_check + (List.for_all + (fun arg -> + not (value_has_ret_symbolic_value_with_borrow_under_mut ctx arg)) + args) + meta; (* Initialize the abstractions and push them in the context. * First, we define the function which, given an initialized, empty @@ -1486,18 +1528,19 @@ and eval_function_call_symbolic_from_inst_sig (config : config) (meta : Meta.met cc (cf Unit) ctx (** Evaluate a non-local function call in symbolic mode *) -and eval_assumed_function_call_symbolic (config : config) (meta : Meta.meta) (fid : assumed_fun_id) - (call : call) (func : fn_ptr) : st_cm_fun = +and eval_assumed_function_call_symbolic (config : config) (meta : Meta.meta) + (fid : assumed_fun_id) (call : call) (func : fn_ptr) : st_cm_fun = fun cf ctx -> let generics = func.generics in let args = call.args in let dest = call.dest in (* Sanity check: make sure the type parameters don't contain regions - * this is a current limitation of our synthesis *) - sanity_check ( - List.for_all - (fun ty -> not (ty_has_borrows ctx.type_ctx.type_infos ty)) - generics.types) meta; + sanity_check + (List.for_all + (fun ty -> not (ty_has_borrows ctx.type_ctx.type_infos ty)) + generics.types) + meta; (* There are two cases (and this is extremely annoying): - the function is not box_free @@ -1534,8 +1577,9 @@ and eval_assumed_function_call_symbolic (config : config) (meta : Meta.meta) (fi in (* Evaluate the function call *) - eval_function_call_symbolic_from_inst_sig config meta (FunId (FAssumed fid)) sg - regions_hierarchy inst_sig generics None args dest cf ctx + eval_function_call_symbolic_from_inst_sig config meta + (FunId (FAssumed fid)) sg regions_hierarchy inst_sig generics None args + dest cf ctx (** Evaluate a statement seen as a function body *) and eval_function_body (config : config) (body : statement) : st_cm_fun = @@ -1550,7 +1594,8 @@ and eval_function_body (config : config) (body : statement) : st_cm_fun = * checking the invariants *) let cc = greedy_expand_symbolic_values config body.meta in (* Sanity check *) - let cc = comp_check_ctx cc (Invariants.check_invariants body.meta) in (* Check if right meta *) + let cc = comp_check_ctx cc (Invariants.check_invariants body.meta) in + (* Check if right meta *) (* Continue *) cc (cf res) in diff --git a/compiler/InterpreterStatements.mli b/compiler/InterpreterStatements.mli index 13743cb1..7a2783bb 100644 --- a/compiler/InterpreterStatements.mli +++ b/compiler/InterpreterStatements.mli @@ -16,7 +16,8 @@ open Cps If the boolean is false, we don't move the return value, and call the continuation with [None]. *) -val pop_frame : config -> Meta.meta -> bool -> (typed_value option -> m_fun) -> m_fun +val pop_frame : + config -> Meta.meta -> bool -> (typed_value option -> m_fun) -> m_fun (** Helper. diff --git a/compiler/InterpreterUtils.ml b/compiler/InterpreterUtils.ml index a24cd543..9ffab771 100644 --- a/compiler/InterpreterUtils.ml +++ b/compiler/InterpreterUtils.ml @@ -17,7 +17,8 @@ let log = Logging.interpreter_log (** Auxiliary function - call a function which requires a continuation, and return the let context given to the continuation *) -let get_cf_ctx_no_synth (meta : Meta.meta) (f : cm_fun) (ctx : eval_ctx) : eval_ctx = +let get_cf_ctx_no_synth (meta : Meta.meta) (f : cm_fun) (ctx : eval_ctx) : + eval_ctx = let nctx = ref None in let cf ctx = sanity_check (!nctx = None) meta; @@ -62,9 +63,14 @@ let statement_to_string ctx = Print.EvalCtx.statement_to_string ctx "" " " let statement_to_string_with_tab ctx = Print.EvalCtx.statement_to_string ctx " " " " -let env_elem_to_string meta ctx = Print.EvalCtx.env_elem_to_string ~meta:(Some meta) ctx "" " " -let env_to_string meta ctx env = eval_ctx_to_string ~meta:(Some meta) { ctx with env } -let abs_to_string meta ctx = Print.EvalCtx.abs_to_string ~meta:(Some meta) ctx "" " " +let env_elem_to_string meta ctx = + Print.EvalCtx.env_elem_to_string ~meta:(Some meta) ctx "" " " + +let env_to_string meta ctx env = + eval_ctx_to_string ~meta:(Some meta) { ctx with env } + +let abs_to_string meta ctx = + Print.EvalCtx.abs_to_string ~meta:(Some meta) ctx "" " " let same_symbolic_id (sv0 : symbolic_value) (sv1 : symbolic_value) : bool = sv0.sv_id = sv1.sv_id @@ -77,19 +83,20 @@ let mk_place_from_var_id (var_id : VarId.id) : place = { var_id; projection = [] } (** Create a fresh symbolic value *) -let mk_fresh_symbolic_value (meta : Meta.meta) (ty : ty) : symbolic_value = +let mk_fresh_symbolic_value (meta : Meta.meta) (ty : ty) : symbolic_value = (* Sanity check *) sanity_check (ty_is_rty ty) meta; let sv_id = fresh_symbolic_value_id () in let svalue = { sv_id; sv_ty = ty } in svalue -let mk_fresh_symbolic_value_from_no_regions_ty (meta : Meta.meta) (ty : ty) : symbolic_value = +let mk_fresh_symbolic_value_from_no_regions_ty (meta : Meta.meta) (ty : ty) : + symbolic_value = sanity_check (ty_no_regions ty) meta; mk_fresh_symbolic_value meta ty (** Create a fresh symbolic value *) -let mk_fresh_symbolic_typed_value (meta : Meta.meta) (rty : ty) : typed_value = +let mk_fresh_symbolic_typed_value (meta : Meta.meta) (rty : ty) : typed_value = sanity_check (ty_is_rty rty) meta; let ty = Substitute.erase_regions rty in (* Generate the fresh a symbolic value *) @@ -97,7 +104,8 @@ let mk_fresh_symbolic_typed_value (meta : Meta.meta) (rty : ty) : typed_value = let value = VSymbolic value in { value; ty } -let mk_fresh_symbolic_typed_value_from_no_regions_ty (meta : Meta.meta) (ty : ty) : typed_value = +let mk_fresh_symbolic_typed_value_from_no_regions_ty (meta : Meta.meta) + (ty : ty) : typed_value = sanity_check (ty_no_regions ty) meta; mk_fresh_symbolic_typed_value meta ty @@ -125,8 +133,9 @@ let mk_aproj_loans_value_from_symbolic_value (regions : RegionId.Set.t) else { value = AIgnored; ty = svalue.sv_ty } (** Create a borrows projector from a symbolic value *) -let mk_aproj_borrows_from_symbolic_value (meta : Meta.meta) (proj_regions : RegionId.Set.t) - (svalue : symbolic_value) (proj_ty : ty) : aproj = +let mk_aproj_borrows_from_symbolic_value (meta : Meta.meta) + (proj_regions : RegionId.Set.t) (svalue : symbolic_value) (proj_ty : ty) : + aproj = sanity_check (ty_is_rty proj_ty) meta; if ty_has_regions_in_set proj_regions proj_ty then AProjBorrows (svalue, proj_ty) @@ -141,8 +150,8 @@ let borrow_in_asb (bid : BorrowId.id) (asb : abstract_shared_borrows) : bool = List.exists (borrow_is_asb bid) asb (** TODO: move *) -let remove_borrow_from_asb (meta : Meta.meta) (bid : BorrowId.id) (asb : abstract_shared_borrows) : - abstract_shared_borrows = +let remove_borrow_from_asb (meta : Meta.meta) (bid : BorrowId.id) + (asb : abstract_shared_borrows) : abstract_shared_borrows = let removed = ref 0 in let asb = List.filter @@ -460,8 +469,8 @@ let initialize_eval_ctx (meta : Meta.meta) (ctx : decls_ctx) region ids. This is mostly used in preparation of function calls (when evaluating in symbolic mode). *) -let instantiate_fun_sig (meta : Meta.meta) (ctx : eval_ctx) (generics : generic_args) - (tr_self : trait_instance_id) (sg : fun_sig) +let instantiate_fun_sig (meta : Meta.meta) (ctx : eval_ctx) + (generics : generic_args) (tr_self : trait_instance_id) (sg : fun_sig) (regions_hierarchy : region_var_groups) : inst_fun_sig = log#ldebug (lazy @@ -514,8 +523,8 @@ let instantiate_fun_sig (meta : Meta.meta) (ctx : eval_ctx) (generics : generic_ in (* Substitute the signature *) let inst_sig = - AssociatedTypes.ctx_subst_norm_signature meta ctx asubst rsubst tsubst cgsubst - tr_subst tr_self sg regions_hierarchy + AssociatedTypes.ctx_subst_norm_signature meta ctx asubst rsubst tsubst + cgsubst tr_subst tr_self sg regions_hierarchy in (* Return *) inst_sig diff --git a/compiler/Invariants.ml b/compiler/Invariants.ml index 9b389ba5..1c10bf7e 100644 --- a/compiler/Invariants.ml +++ b/compiler/Invariants.ml @@ -48,14 +48,16 @@ type borrow_kind = BMut | BShared | BReserved - loans and borrows are correctly related - a two-phase borrow can't point to a value inside an abstraction *) -let check_loans_borrows_relation_invariant (meta : Meta.meta) (ctx : eval_ctx) : unit = +let check_loans_borrows_relation_invariant (meta : Meta.meta) (ctx : eval_ctx) : + unit = (* Link all the borrow ids to a representant - necessary because of shared * borrows/loans *) let ids_reprs : BorrowId.id BorrowId.Map.t ref = ref BorrowId.Map.empty in (* Link all the id representants to a borrow information *) let borrows_infos : borrow_info BorrowId.Map.t ref = ref BorrowId.Map.empty in let context_to_string () : string = - eval_ctx_to_string ~meta:(Some meta) ctx ^ "- representants:\n" + eval_ctx_to_string ~meta:(Some meta) ctx + ^ "- representants:\n" ^ ids_reprs_to_string " " !ids_reprs ^ "\n- info:\n" ^ borrows_infos_to_string " " !borrows_infos @@ -194,9 +196,7 @@ let check_loans_borrows_relation_invariant (meta : Meta.meta) (ctx : eval_ctx) : let infos = BorrowId.Map.update repr_bid (fun x -> - match x with - | Some _ -> Some info - | None -> craise meta "Unreachable") + match x with Some _ -> Some info | None -> craise meta "Unreachable") !borrows_infos in borrows_infos := infos @@ -278,9 +278,10 @@ let check_loans_borrows_relation_invariant (meta : Meta.meta) (ctx : eval_ctx) : (fun _ info -> (* Note that we can't directly compare the sets - I guess they are * different depending on the order in which we add the elements... *) - sanity_check ( - BorrowId.Set.elements info.loan_ids - = BorrowId.Set.elements info.borrow_ids) meta; + sanity_check + (BorrowId.Set.elements info.loan_ids + = BorrowId.Set.elements info.borrow_ids) + meta; match info.loan_kind with | RMut -> sanity_check (BorrowId.Set.cardinal info.loan_ids = 1) meta | RShared -> ()) @@ -297,7 +298,9 @@ let check_borrowed_values_invariant (meta : Meta.meta) (ctx : eval_ctx) : unit = method! visit_VBottom info = (* No ⊥ inside borrowed values *) - sanity_check (Config.allow_bottom_below_borrow || not info.outer_borrow) meta + sanity_check + (Config.allow_bottom_below_borrow || not info.outer_borrow) + meta method! visit_ABottom _info = (* ⊥ inside an abstraction is not the same as in a regular value *) @@ -367,7 +370,8 @@ let check_borrowed_values_invariant (meta : Meta.meta) (ctx : eval_ctx) : unit = let info = { outer_borrow = false; outer_shared = false } in visitor#visit_eval_ctx info ctx -let check_literal_type (meta : Meta.meta) (cv : literal) (ty : literal_type) : unit = +let check_literal_type (meta : Meta.meta) (cv : literal) (ty : literal_type) : + unit = match (cv, ty) with | VScalar sv, TInteger int_ty -> sanity_check (sv.int_ty = int_ty) meta | VBool _, TBool | VChar _, TChar -> () @@ -413,13 +417,18 @@ let check_typing_invariant (meta : Meta.meta) (ctx : eval_ctx) : unit = * parameters, etc. *) let def = ctx_lookup_type_decl ctx def_id in (* Check the number of parameters *) - sanity_check ( - List.length generics.regions = List.length def.generics.regions) meta; - sanity_check (List.length generics.types = List.length def.generics.types) meta; + sanity_check + (List.length generics.regions = List.length def.generics.regions) + meta; + sanity_check + (List.length generics.types = List.length def.generics.types) + meta; (* Check that the variant id is consistent *) (match (av.variant_id, def.kind) with | Some variant_id, Enum variants -> - sanity_check (VariantId.to_int variant_id < List.length variants) meta + sanity_check + (VariantId.to_int variant_id < List.length variants) + meta | None, Struct _ -> () | _ -> craise meta "Erroneous typing"); (* Check that the field types are correct *) @@ -429,7 +438,8 @@ let check_typing_invariant (meta : Meta.meta) (ctx : eval_ctx) : unit = in let fields_with_types = List.combine av.field_values field_types in List.iter - (fun ((v, ty) : typed_value * ty) -> sanity_check (v.ty = ty) meta) + (fun ((v, ty) : typed_value * ty) -> + sanity_check (v.ty = ty) meta) fields_with_types (* Tuple case *) | VAdt av, TAdt (TTuple, generics) -> @@ -442,7 +452,8 @@ let check_typing_invariant (meta : Meta.meta) (ctx : eval_ctx) : unit = List.combine av.field_values generics.types in List.iter - (fun ((v, ty) : typed_value * ty) -> sanity_check (v.ty = ty) meta) + (fun ((v, ty) : typed_value * ty) -> + sanity_check (v.ty = ty) meta) fields_with_types (* Assumed type case *) | VAdt av, TAdt (TAssumed aty_id, generics) -> ( @@ -459,10 +470,11 @@ let check_typing_invariant (meta : Meta.meta) (ctx : eval_ctx) : unit = sanity_check (inner_value.ty = inner_ty) meta | TArray, inner_values, _, [ inner_ty ], [ cg ] -> (* *) - sanity_check ( - List.for_all - (fun (v : typed_value) -> v.ty = inner_ty) - inner_values) meta; + sanity_check + (List.for_all + (fun (v : typed_value) -> v.ty = inner_ty) + inner_values) + meta; (* The length is necessarily concrete *) let len = (ValuesUtils.literal_as_scalar @@ -484,9 +496,10 @@ let check_typing_invariant (meta : Meta.meta) (ctx : eval_ctx) : unit = sanity_check (sv.ty = ref_ty) meta | _ -> craise meta "Inconsistent context") | VMutBorrow (_, bv), RMut -> - sanity_check ( - (* Check that the borrowed value has the proper type *) - bv.ty = ref_ty) meta + sanity_check + ((* Check that the borrowed value has the proper type *) + bv.ty = ref_ty) + meta | _ -> craise meta "Erroneous typing") | VLoan lc, ty -> ( match lc with @@ -495,7 +508,8 @@ let check_typing_invariant (meta : Meta.meta) (ctx : eval_ctx) : unit = (* Lookup the borrowed value to check it has the proper type *) let glc = lookup_borrow meta ek_all bid ctx in match glc with - | Concrete (VMutBorrow (_, bv)) -> sanity_check (bv.ty = ty) meta + | Concrete (VMutBorrow (_, bv)) -> + sanity_check (bv.ty = ty) meta | Abstract (AMutBorrow (_, sv)) -> sanity_check (Substitute.erase_regions sv.ty = ty) meta | _ -> craise meta "Inconsistent context")) @@ -525,16 +539,22 @@ let check_typing_invariant (meta : Meta.meta) (ctx : eval_ctx) : unit = * parameters, etc. *) let def = ctx_lookup_type_decl ctx def_id in (* Check the number of parameters *) - sanity_check ( - List.length generics.regions = List.length def.generics.regions) meta; - sanity_check (List.length generics.types = List.length def.generics.types) meta; - sanity_check ( - List.length generics.const_generics - = List.length def.generics.const_generics) meta; + sanity_check + (List.length generics.regions = List.length def.generics.regions) + meta; + sanity_check + (List.length generics.types = List.length def.generics.types) + meta; + sanity_check + (List.length generics.const_generics + = List.length def.generics.const_generics) + meta; (* Check that the variant id is consistent *) (match (av.variant_id, def.kind) with | Some variant_id, Enum variants -> - sanity_check (VariantId.to_int variant_id < List.length variants) meta + sanity_check + (VariantId.to_int variant_id < List.length variants) + meta | None, Struct _ -> () | _ -> craise meta "Erroneous typing"); (* Check that the field types are correct *) @@ -544,7 +564,8 @@ let check_typing_invariant (meta : Meta.meta) (ctx : eval_ctx) : unit = in let fields_with_types = List.combine av.field_values field_types in List.iter - (fun ((v, ty) : typed_avalue * ty) -> sanity_check (v.ty = ty) meta) + (fun ((v, ty) : typed_avalue * ty) -> + sanity_check (v.ty = ty) meta) fields_with_types (* Tuple case *) | AAdt av, TAdt (TTuple, generics) -> @@ -557,7 +578,8 @@ let check_typing_invariant (meta : Meta.meta) (ctx : eval_ctx) : unit = List.combine av.field_values generics.types in List.iter - (fun ((v, ty) : typed_avalue * ty) -> sanity_check (v.ty = ty) meta) + (fun ((v, ty) : typed_avalue * ty) -> + sanity_check (v.ty = ty) meta) fields_with_types (* Assumed type case *) | AAdt av, TAdt (TAssumed aty_id, generics) -> ( @@ -587,7 +609,8 @@ let check_typing_invariant (meta : Meta.meta) (ctx : eval_ctx) : unit = | Abstract (ASharedLoan (_, sv, _)) -> sanity_check (sv.ty = Substitute.erase_regions ref_ty) meta | _ -> craise meta "Inconsistent context") - | AIgnoredMutBorrow (_opt_bid, av), RMut -> sanity_check (av.ty = ref_ty) meta + | AIgnoredMutBorrow (_opt_bid, av), RMut -> + sanity_check (av.ty = ref_ty) meta | ( AEndedIgnoredMutBorrow { given_back; child; given_back_meta = _ }, RMut ) -> sanity_check (given_back.ty = ref_ty) meta; @@ -604,18 +627,23 @@ let check_typing_invariant (meta : Meta.meta) (ctx : eval_ctx) : unit = let glc = lookup_borrow meta ek_all bid ctx in match glc with | Concrete (VMutBorrow (_, bv)) -> - sanity_check (bv.ty = Substitute.erase_regions borrowed_aty) meta + sanity_check + (bv.ty = Substitute.erase_regions borrowed_aty) + meta | Abstract (AMutBorrow (_, sv)) -> - sanity_check ( - Substitute.erase_regions sv.ty - = Substitute.erase_regions borrowed_aty) meta + sanity_check + (Substitute.erase_regions sv.ty + = Substitute.erase_regions borrowed_aty) + meta | _ -> craise meta "Inconsistent context") | AIgnoredMutLoan (None, child_av) -> let borrowed_aty = aloan_get_expected_child_type aty in sanity_check (child_av.ty = borrowed_aty) meta | ASharedLoan (_, sv, child_av) | AEndedSharedLoan (sv, child_av) -> let borrowed_aty = aloan_get_expected_child_type aty in - sanity_check (sv.ty = Substitute.erase_regions borrowed_aty) meta; + sanity_check + (sv.ty = Substitute.erase_regions borrowed_aty) + meta; (* TODO: the type of aloans doesn't make sense, see above *) sanity_check (child_av.ty = borrowed_aty) meta | AEndedMutLoan { given_back; child; given_back_meta = _ } @@ -624,7 +652,9 @@ let check_typing_invariant (meta : Meta.meta) (ctx : eval_ctx) : unit = sanity_check (given_back.ty = borrowed_aty) meta; sanity_check (child.ty = borrowed_aty) meta | AIgnoredSharedLoan child_av -> - sanity_check (child_av.ty = aloan_get_expected_child_type aty) meta) + sanity_check + (child_av.ty = aloan_get_expected_child_type aty) + meta) | ASymbolic aproj, ty -> ( let ty1 = Substitute.erase_regions ty in match aproj with @@ -772,7 +802,9 @@ let check_symbolic_values (meta : Meta.meta) (ctx : eval_ctx) : unit = if ty_has_borrows ctx.type_ctx.type_infos info.ty then sanity_check (info.env_count <= 1) meta; (* A duplicated symbolic value is necessarily primitively copyable *) - sanity_check (info.env_count <= 1 || ty_is_primitively_copyable info.ty) meta; + sanity_check + (info.env_count <= 1 || ty_is_primitively_copyable info.ty) + meta; sanity_check (info.aproj_borrows = [] || info.aproj_loans <> []) meta; (* At the same time: @@ -796,8 +828,10 @@ let check_symbolic_values (meta : Meta.meta) (ctx : eval_ctx) : unit = (* Check that the union of the loan projectors contains the borrow projections. *) List.iter (fun binfo -> - sanity_check ( - projection_contains meta info.ty loan_regions binfo.proj_ty binfo.regions) meta) + sanity_check + (projection_contains meta info.ty loan_regions binfo.proj_ty + binfo.regions) + meta) info.aproj_borrows; () in @@ -806,7 +840,9 @@ let check_symbolic_values (meta : Meta.meta) (ctx : eval_ctx) : unit = let check_invariants (meta : Meta.meta) (ctx : eval_ctx) : unit = if !Config.sanity_checks then ( - log#ldebug (lazy ("Checking invariants:\n" ^ eval_ctx_to_string ~meta:(Some meta) ctx)); + log#ldebug + (lazy + ("Checking invariants:\n" ^ eval_ctx_to_string ~meta:(Some meta) ctx)); check_loans_borrows_relation_invariant meta ctx; check_borrowed_values_invariant meta ctx; check_typing_invariant meta ctx; diff --git a/compiler/Main.ml b/compiler/Main.ml index f8765247..41addc81 100644 --- a/compiler/Main.ml +++ b/compiler/Main.ml @@ -113,7 +113,9 @@ let () = Arg.Clear lean_gen_lakefile, " Generate a default lakefile.lean (Lean only)" ); ("-print-llbc", Arg.Set print_llbc, " Print the imported LLBC"); - ("-abort-on-error", Arg.Set fail_hard, "Abort on the first encountered error"); + ( "-abort-on-error", + Arg.Set fail_hard, + "Abort on the first encountered error" ); ( "-tuple-nested-proj", Arg.Set use_nested_tuple_projectors, " Use nested projectors for tuples (e.g., (0, 1).snd.fst instead of \ diff --git a/compiler/PrePasses.ml b/compiler/PrePasses.ml index c10dbf5d..42857a88 100644 --- a/compiler/PrePasses.ml +++ b/compiler/PrePasses.ml @@ -215,7 +215,8 @@ let remove_loop_breaks (crate : crate) (f : fun_decl) : fun_decl = inherit [_] map_statement as super method! visit_Loop entered_loop loop = - cassert (not entered_loop) st.meta "Nested loops are not supported yet"; + cassert (not entered_loop) st.meta + "Nested loops are not supported yet"; super#visit_Loop true loop method! visit_Break _ i = @@ -396,9 +397,16 @@ let remove_shallow_borrows (crate : crate) (f : fun_decl) : fun_decl = let check_visitor = object inherit [_] iter_statement as super - (* Remember the span of the statement we enter *) + (* Remember the span of the statement we enter *) + method! visit_statement _ st = super#visit_statement st.meta st - method! visit_var_id meta id = cassert (not (VarId.Set.mem id !filtered)) meta "Filtered variables should have completely disappeared from the body" + + method! visit_var_id meta id = + cassert + (not (VarId.Set.mem id !filtered)) + meta + "Filtered variables should have completely disappeared from the \ + body" end in check_visitor#visit_statement body.meta body; diff --git a/compiler/Print.ml b/compiler/Print.ml index 47ae9b79..b570bf5f 100644 --- a/compiler/Print.ml +++ b/compiler/Print.ml @@ -43,12 +43,13 @@ module Values = struct * typed_avalue_to_string. At some point we had done it, because [typed_value] * and [typed_avalue] were instances of the same general type [g_typed_value], * but then we removed this general type because it proved to be a bad idea. *) - let rec typed_value_to_string ?(meta : Meta.meta option = None) (env : fmt_env) (v : typed_value) : string = + let rec typed_value_to_string ?(meta : Meta.meta option = None) + (env : fmt_env) (v : typed_value) : string = match v.value with | VLiteral cv -> literal_to_string cv | VAdt av -> ( let field_values = - List.map (typed_value_to_string~meta:meta env) av.field_values + List.map (typed_value_to_string ~meta env) av.field_values in match v.ty with | TAdt (TTuple, _) -> @@ -83,28 +84,31 @@ module Values = struct | TArray, _ -> (* Happens when we aggregate values *) "@Array[" ^ String.concat ", " field_values ^ "]" - | _ -> craise_opt_meta meta ("Inconsistent value: " ^ show_typed_value v) - ) + | _ -> + craise_opt_meta meta + ("Inconsistent value: " ^ show_typed_value v)) | _ -> craise_opt_meta meta "Inconsistent typed value") | VBottom -> "⊥ : " ^ ty_to_string env v.ty - | VBorrow bc -> borrow_content_to_string ~meta:meta env bc - | VLoan lc -> loan_content_to_string ~meta:meta env lc + | VBorrow bc -> borrow_content_to_string ~meta env bc + | VLoan lc -> loan_content_to_string ~meta env lc | VSymbolic s -> symbolic_value_to_string env s - and borrow_content_to_string ?(meta : Meta.meta option = None) (env : fmt_env) (bc : borrow_content) : string = + and borrow_content_to_string ?(meta : Meta.meta option = None) (env : fmt_env) + (bc : borrow_content) : string = match bc with | VSharedBorrow bid -> "shared_borrow@" ^ BorrowId.to_string bid | VMutBorrow (bid, tv) -> "mut_borrow@" ^ BorrowId.to_string bid ^ " (" - ^ typed_value_to_string ~meta:meta env tv + ^ typed_value_to_string ~meta env tv ^ ")" | VReservedMutBorrow bid -> "reserved_borrow@" ^ BorrowId.to_string bid - and loan_content_to_string ?(meta : Meta.meta option = None) (env : fmt_env) (lc : loan_content) : string = + and loan_content_to_string ?(meta : Meta.meta option = None) (env : fmt_env) + (lc : loan_content) : string = match lc with | VSharedLoan (loans, v) -> let loans = BorrowId.Set.to_string None loans in - "@shared_loan(" ^ loans ^ ", " ^ typed_value_to_string ~meta:meta env v ^ ")" + "@shared_loan(" ^ loans ^ ", " ^ typed_value_to_string ~meta env v ^ ")" | VMutLoan bid -> "ml@" ^ BorrowId.to_string bid let abstract_shared_borrow_to_string (env : fmt_env) @@ -142,11 +146,12 @@ module Values = struct | AEndedProjBorrows _mv -> "_" | AIgnoredProjBorrows -> "_" - let rec typed_avalue_to_string ?(meta : Meta.meta option = None) (env : fmt_env) (v : typed_avalue) : string = + let rec typed_avalue_to_string ?(meta : Meta.meta option = None) + (env : fmt_env) (v : typed_avalue) : string = match v.value with | AAdt av -> ( let field_values = - List.map (typed_avalue_to_string ~meta:meta env) av.field_values + List.map (typed_avalue_to_string ~meta env) av.field_values in match v.ty with | TAdt (TTuple, _) -> @@ -181,72 +186,73 @@ module Values = struct | _ -> craise_opt_meta meta "Inconsistent value") | _ -> craise_opt_meta meta "Inconsistent typed value") | ABottom -> "⊥ : " ^ ty_to_string env v.ty - | ABorrow bc -> aborrow_content_to_string ~meta:meta env bc - | ALoan lc -> aloan_content_to_string ~meta:meta env lc + | ABorrow bc -> aborrow_content_to_string ~meta env bc + | ALoan lc -> aloan_content_to_string ~meta env lc | ASymbolic s -> aproj_to_string env s | AIgnored -> "_" - and aloan_content_to_string ?(meta : Meta.meta option = None) (env : fmt_env) (lc : aloan_content) : string = + and aloan_content_to_string ?(meta : Meta.meta option = None) (env : fmt_env) + (lc : aloan_content) : string = match lc with | AMutLoan (bid, av) -> "@mut_loan(" ^ BorrowId.to_string bid ^ ", " - ^ typed_avalue_to_string ~meta:meta env av + ^ typed_avalue_to_string ~meta env av ^ ")" | ASharedLoan (loans, v, av) -> let loans = BorrowId.Set.to_string None loans in "@shared_loan(" ^ loans ^ ", " - ^ typed_value_to_string ~meta:meta env v + ^ typed_value_to_string ~meta env v ^ ", " - ^ typed_avalue_to_string ~meta:meta env av + ^ typed_avalue_to_string ~meta env av ^ ")" | AEndedMutLoan ml -> "@ended_mut_loan{" - ^ typed_avalue_to_string ~meta:meta env ml.child + ^ typed_avalue_to_string ~meta env ml.child ^ "; " - ^ typed_avalue_to_string ~meta:meta env ml.given_back + ^ typed_avalue_to_string ~meta env ml.given_back ^ " }" | AEndedSharedLoan (v, av) -> "@ended_shared_loan(" - ^ typed_value_to_string ~meta:meta env v + ^ typed_value_to_string ~meta env v ^ ", " - ^ typed_avalue_to_string ~meta:meta env av + ^ typed_avalue_to_string ~meta env av ^ ")" | AIgnoredMutLoan (opt_bid, av) -> "@ignored_mut_loan(" ^ option_to_string BorrowId.to_string opt_bid ^ ", " - ^ typed_avalue_to_string ~meta:meta env av + ^ typed_avalue_to_string ~meta env av ^ ")" | AEndedIgnoredMutLoan ml -> "@ended_ignored_mut_loan{ " - ^ typed_avalue_to_string ~meta:meta env ml.child + ^ typed_avalue_to_string ~meta env ml.child ^ "; " - ^ typed_avalue_to_string ~meta:meta env ml.given_back + ^ typed_avalue_to_string ~meta env ml.given_back ^ "}" | AIgnoredSharedLoan sl -> - "@ignored_shared_loan(" ^ typed_avalue_to_string ~meta:meta env sl ^ ")" + "@ignored_shared_loan(" ^ typed_avalue_to_string ~meta env sl ^ ")" - and aborrow_content_to_string ?(meta : Meta.meta option = None) (env : fmt_env) (bc : aborrow_content) : string - = + and aborrow_content_to_string ?(meta : Meta.meta option = None) + (env : fmt_env) (bc : aborrow_content) : string = match bc with | AMutBorrow (bid, av) -> "mb@" ^ BorrowId.to_string bid ^ " (" - ^ typed_avalue_to_string ~meta:meta env av + ^ typed_avalue_to_string ~meta env av ^ ")" | ASharedBorrow bid -> "sb@" ^ BorrowId.to_string bid | AIgnoredMutBorrow (opt_bid, av) -> "@ignored_mut_borrow(" ^ option_to_string BorrowId.to_string opt_bid ^ ", " - ^ typed_avalue_to_string ~meta:meta env av + ^ typed_avalue_to_string ~meta env av ^ ")" | AEndedMutBorrow (_mv, child) -> - "@ended_mut_borrow(" ^ typed_avalue_to_string ~meta:meta env child ^ ")" + "@ended_mut_borrow(" ^ typed_avalue_to_string ~meta env child ^ ")" | AEndedIgnoredMutBorrow { child; given_back; given_back_meta = _ } -> "@ended_ignored_mut_borrow{ " - ^ typed_avalue_to_string ~meta:meta env child + ^ typed_avalue_to_string ~meta env child ^ "; " - ^ typed_avalue_to_string ~meta:meta env given_back + ^ typed_avalue_to_string ~meta env given_back ^ ")" | AEndedSharedBorrow -> "@ended_shared_borrow" | AProjSharedBorrow sb -> @@ -276,11 +282,14 @@ module Values = struct ^ ")" | Identity -> "Identity" - let abs_to_string ?(meta : Meta.meta option = None) (env : fmt_env) (verbose : bool) (indent : string) - (indent_incr : string) (abs : abs) : string = + let abs_to_string ?(meta : Meta.meta option = None) (env : fmt_env) + (verbose : bool) (indent : string) (indent_incr : string) (abs : abs) : + string = let indent2 = indent ^ indent_incr in let avs = - List.map (fun av -> indent2 ^ typed_avalue_to_string ~meta:meta env av) abs.avalues + List.map + (fun av -> indent2 ^ typed_avalue_to_string ~meta env av) + abs.avalues in let avs = String.concat ",\n" avs in let kind = @@ -323,26 +332,27 @@ module Contexts = struct | BVar b -> var_binder_to_string env b | BDummy bid -> dummy_var_id_to_string bid - let env_elem_to_string ?(meta : Meta.meta option = None) (env : fmt_env) (verbose : bool) - (with_var_types : bool) (indent : string) (indent_incr : string) - (ev : env_elem) : string = + let env_elem_to_string ?(meta : Meta.meta option = None) (env : fmt_env) + (verbose : bool) (with_var_types : bool) (indent : string) + (indent_incr : string) (ev : env_elem) : string = match ev with | EBinding (var, tv) -> let bv = binder_to_string env var in let ty = if with_var_types then " : " ^ ty_to_string env tv.ty else "" in - indent ^ bv ^ ty ^ " -> " ^ typed_value_to_string ~meta:meta env tv ^ " ;" - | EAbs abs -> abs_to_string ~meta:meta env verbose indent indent_incr abs + indent ^ bv ^ ty ^ " -> " ^ typed_value_to_string ~meta env tv ^ " ;" + | EAbs abs -> abs_to_string ~meta env verbose indent indent_incr abs | EFrame -> craise_opt_meta meta "Can't print a Frame element" - let opt_env_elem_to_string ?(meta : Meta.meta option = None) (env : fmt_env) (verbose : bool) - (with_var_types : bool) (indent : string) (indent_incr : string) - (ev : env_elem option) : string = + let opt_env_elem_to_string ?(meta : Meta.meta option = None) (env : fmt_env) + (verbose : bool) (with_var_types : bool) (indent : string) + (indent_incr : string) (ev : env_elem option) : string = match ev with | None -> indent ^ "..." | Some ev -> - env_elem_to_string ~meta:meta env verbose with_var_types indent indent_incr ev + env_elem_to_string ~meta env verbose with_var_types indent indent_incr + ev (** Filters "dummy" bindings from an environment, to gain space and clarity/ See [env_to_string]. *) @@ -379,8 +389,9 @@ module Contexts = struct "..." to gain space and clarity. [with_var_types]: if true, print the type of the variables *) - let env_to_string ?(meta : Meta.meta option = None) (filter : bool) (fmt_env : fmt_env) (verbose : bool) - (with_var_types : bool) (env : env) : string = + let env_to_string ?(meta : Meta.meta option = None) (filter : bool) + (fmt_env : fmt_env) (verbose : bool) (with_var_types : bool) (env : env) : + string = let env = if filter then filter_env env else List.map (fun ev -> Some ev) env in @@ -388,7 +399,8 @@ module Contexts = struct ^ String.concat "\n" (List.map (fun ev -> - opt_env_elem_to_string ~meta:meta fmt_env verbose with_var_types " " " " ev) + opt_env_elem_to_string ~meta fmt_env verbose with_var_types " " + " " ev) env) ^ "\n}" @@ -468,8 +480,8 @@ module Contexts = struct let frames = split_aux [] [] env in frames - let eval_ctx_to_string_gen ?(meta : Meta.meta option = None) (verbose : bool) (filter : bool) - (with_var_types : bool) (ctx : eval_ctx) : string = + let eval_ctx_to_string_gen ?(meta : Meta.meta option = None) (verbose : bool) + (filter : bool) (with_var_types : bool) (ctx : eval_ctx) : string = let fmt_env = eval_ctx_to_fmt_env ctx in let ended_regions = RegionId.Set.to_string None ctx.ended_regions in let frames = split_env_according_to_frames ctx.env in @@ -492,18 +504,20 @@ module Contexts = struct ^ string_of_int !num_bindings ^ "\n- dummy bindings: " ^ string_of_int !num_dummies ^ "\n- abstractions: " ^ string_of_int !num_abs ^ "\n" - ^ env_to_string ~meta:meta filter fmt_env verbose with_var_types f + ^ env_to_string ~meta filter fmt_env verbose with_var_types f ^ "\n") frames in "# Ended regions: " ^ ended_regions ^ "\n" ^ "# " ^ string_of_int num_frames ^ " frame(s)\n" ^ String.concat "" frames - let eval_ctx_to_string ?(meta : Meta.meta option = None) (ctx : eval_ctx) : string = - eval_ctx_to_string_gen ~meta:meta false true true ctx + let eval_ctx_to_string ?(meta : Meta.meta option = None) (ctx : eval_ctx) : + string = + eval_ctx_to_string_gen ~meta false true true ctx - let eval_ctx_to_string_no_filter ?(meta : Meta.meta option = None) (ctx : eval_ctx) : string = - eval_ctx_to_string_gen ~meta:meta false false true ctx + let eval_ctx_to_string_no_filter ?(meta : Meta.meta option = None) + (ctx : eval_ctx) : string = + eval_ctx_to_string_gen ~meta false false true ctx end (** Pretty-printing for LLBC ASTs (functions based on an evaluation context) *) @@ -541,22 +555,25 @@ module EvalCtx = struct let env = eval_ctx_to_fmt_env ctx in trait_instance_id_to_string env x - let borrow_content_to_string ?(meta : Meta.meta option = None) (ctx : eval_ctx) (bc : borrow_content) : string = + let borrow_content_to_string ?(meta : Meta.meta option = None) + (ctx : eval_ctx) (bc : borrow_content) : string = let env = eval_ctx_to_fmt_env ctx in - borrow_content_to_string ~meta:meta env bc + borrow_content_to_string ~meta env bc - let loan_content_to_string ?(meta : Meta.meta option = None) (ctx : eval_ctx) (lc : loan_content) : string = + let loan_content_to_string ?(meta : Meta.meta option = None) (ctx : eval_ctx) + (lc : loan_content) : string = let env = eval_ctx_to_fmt_env ctx in - loan_content_to_string ~meta:meta env lc + loan_content_to_string ~meta env lc - let aborrow_content_to_string ?(meta : Meta.meta option = None) (ctx : eval_ctx) (bc : aborrow_content) : string - = + let aborrow_content_to_string ?(meta : Meta.meta option = None) + (ctx : eval_ctx) (bc : aborrow_content) : string = let env = eval_ctx_to_fmt_env ctx in - aborrow_content_to_string ~meta:meta env bc + aborrow_content_to_string ~meta env bc - let aloan_content_to_string ?(meta : Meta.meta option = None) (ctx : eval_ctx) (lc : aloan_content) : string = + let aloan_content_to_string ?(meta : Meta.meta option = None) (ctx : eval_ctx) + (lc : aloan_content) : string = let env = eval_ctx_to_fmt_env ctx in - aloan_content_to_string ~meta:meta env lc + aloan_content_to_string ~meta env lc let aproj_to_string (ctx : eval_ctx) (p : aproj) : string = let env = eval_ctx_to_fmt_env ctx in @@ -566,13 +583,15 @@ module EvalCtx = struct let env = eval_ctx_to_fmt_env ctx in symbolic_value_to_string env sv - let typed_value_to_string ?(meta : Meta.meta option = None) (ctx : eval_ctx) (v : typed_value) : string = + let typed_value_to_string ?(meta : Meta.meta option = None) (ctx : eval_ctx) + (v : typed_value) : string = let env = eval_ctx_to_fmt_env ctx in - typed_value_to_string ~meta:meta env v + typed_value_to_string ~meta env v - let typed_avalue_to_string ?(meta : Meta.meta option = None) (ctx : eval_ctx) (v : typed_avalue) : string = + let typed_avalue_to_string ?(meta : Meta.meta option = None) (ctx : eval_ctx) + (v : typed_avalue) : string = let env = eval_ctx_to_fmt_env ctx in - typed_avalue_to_string ~meta:meta env v + typed_avalue_to_string ~meta env v let place_to_string (ctx : eval_ctx) (op : place) : string = let env = eval_ctx_to_fmt_env ctx in @@ -613,13 +632,13 @@ module EvalCtx = struct let env = eval_ctx_to_fmt_env ctx in trait_impl_to_string env " " " " timpl - let env_elem_to_string ?(meta : Meta.meta option = None) (ctx : eval_ctx) (indent : string) - (indent_incr : string) (ev : env_elem) : string = + let env_elem_to_string ?(meta : Meta.meta option = None) (ctx : eval_ctx) + (indent : string) (indent_incr : string) (ev : env_elem) : string = let env = eval_ctx_to_fmt_env ctx in - env_elem_to_string ~meta:meta env false true indent indent_incr ev + env_elem_to_string ~meta env false true indent indent_incr ev - let abs_to_string ?(meta : Meta.meta option = None) (ctx : eval_ctx) (indent : string) (indent_incr : string) - (abs : abs) : string = + let abs_to_string ?(meta : Meta.meta option = None) (ctx : eval_ctx) + (indent : string) (indent_incr : string) (abs : abs) : string = let env = eval_ctx_to_fmt_env ctx in - abs_to_string ~meta:meta env false indent indent_incr abs + abs_to_string ~meta env false indent indent_incr abs end diff --git a/compiler/PrintPure.ml b/compiler/PrintPure.ml index 6ef87194..1162251a 100644 --- a/compiler/PrintPure.ml +++ b/compiler/PrintPure.ml @@ -314,17 +314,22 @@ let adt_variant_to_string ?(meta = None) (env : fmt_env) (adt_id : type_id) if variant_id = result_return_id then "@Result::Return" else if variant_id = result_fail_id then "@Result::Fail" else - craise_opt_meta meta "Unreachable: improper variant id for result type" + craise_opt_meta meta + "Unreachable: improper variant id for result type" | TError -> let variant_id = Option.get variant_id in if variant_id = error_failure_id then "@Error::Failure" else if variant_id = error_out_of_fuel_id then "@Error::OutOfFuel" - else craise_opt_meta meta "Unreachable: improper variant id for error type" + else + craise_opt_meta meta + "Unreachable: improper variant id for error type" | TFuel -> let variant_id = Option.get variant_id in if variant_id = fuel_zero_id then "@Fuel::Zero" else if variant_id = fuel_succ_id then "@Fuel::Succ" - else craise_opt_meta meta "Unreachable: improper variant id for fuel type") + else + craise_opt_meta meta + "Unreachable: improper variant id for fuel type") let adt_field_to_string ?(meta = None) (env : fmt_env) (adt_id : type_id) (field_id : FieldId.id) : string = @@ -351,9 +356,9 @@ let adt_field_to_string ?(meta = None) (env : fmt_env) (adt_id : type_id) (** TODO: we don't need a general function anymore (it is now only used for patterns) *) -let adt_g_value_to_string ?(meta : Meta.meta option = None) (env : fmt_env) (value_to_string : 'v -> string) - (variant_id : VariantId.id option) (field_values : 'v list) (ty : ty) : - string = +let adt_g_value_to_string ?(meta : Meta.meta option = None) (env : fmt_env) + (value_to_string : 'v -> string) (variant_id : VariantId.id option) + (field_values : 'v list) (ty : ty) : string = let field_values = List.map value_to_string field_values in match ty with | TAdt (TTuple, _) -> @@ -398,13 +403,16 @@ let adt_g_value_to_string ?(meta : Meta.meta option = None) (env : fmt_env) (val | [ v ] -> "@Result::Fail " ^ v | _ -> craise_opt_meta meta "Result::Fail takes exactly one value" else - craise_opt_meta meta "Unreachable: improper variant id for result type" + craise_opt_meta meta + "Unreachable: improper variant id for result type" | TError -> cassert_opt_meta (field_values = []) meta "TODO: error message"; let variant_id = Option.get variant_id in if variant_id = error_failure_id then "@Error::Failure" else if variant_id = error_out_of_fuel_id then "@Error::OutOfFuel" - else craise_opt_meta meta "Unreachable: improper variant id for error type" + else + craise_opt_meta meta + "Unreachable: improper variant id for error type" | TFuel -> let variant_id = Option.get variant_id in if variant_id = fuel_zero_id then ( @@ -414,7 +422,9 @@ let adt_g_value_to_string ?(meta : Meta.meta option = None) (env : fmt_env) (val match field_values with | [ v ] -> "@Fuel::Succ " ^ v | _ -> craise_opt_meta meta "@Fuel::Succ takes exactly one value" - else craise_opt_meta meta "Unreachable: improper variant id for fuel type" + else + craise_opt_meta meta + "Unreachable: improper variant id for fuel type" | TArray | TSlice | TStr -> cassert_opt_meta (variant_id = None) meta "TODO: error message"; let field_values = @@ -423,13 +433,13 @@ let adt_g_value_to_string ?(meta : Meta.meta option = None) (env : fmt_env) (val let id = assumed_ty_to_string aty in id ^ " [" ^ String.concat "; " field_values ^ "]") | _ -> - craise_opt_meta - meta - ("Inconsistently typed value: expected ADT type but found:" - ^ "\n- ty: " ^ ty_to_string env false ty ^ "\n- variant_id: " - ^ Print.option_to_string VariantId.to_string variant_id) + craise_opt_meta meta + ("Inconsistently typed value: expected ADT type but found:" ^ "\n- ty: " + ^ ty_to_string env false ty ^ "\n- variant_id: " + ^ Print.option_to_string VariantId.to_string variant_id) -let rec typed_pattern_to_string ?(meta : Meta.meta option = None) (env : fmt_env) (v : typed_pattern) : string = +let rec typed_pattern_to_string ?(meta : Meta.meta option = None) + (env : fmt_env) (v : typed_pattern) : string = match v.value with | PatConstant cv -> literal_to_string cv | PatVar (v, None) -> var_to_string env v @@ -440,8 +450,8 @@ let rec typed_pattern_to_string ?(meta : Meta.meta option = None) (env : fmt_env ^ ")" | PatDummy -> "_" | PatAdt av -> - adt_g_value_to_string ~meta:meta env - (typed_pattern_to_string ~meta:meta env) + adt_g_value_to_string ~meta env + (typed_pattern_to_string ~meta env) av.variant_id av.field_values v.ty let fun_sig_to_string (env : fmt_env) (sg : fun_sig) : string = @@ -522,8 +532,9 @@ let fun_or_op_id_to_string (env : fmt_env) (fun_id : fun_or_op_id) : string = binop_to_string binop ^ "<" ^ integer_type_to_string int_ty ^ ">" (** [inside]: controls the introduction of parentheses *) -let rec texpression_to_string ?(metadata : Meta.meta option = None) (env : fmt_env) (inside : bool) (indent : string) - (indent_incr : string) (e : texpression) : string = +let rec texpression_to_string ?(metadata : Meta.meta option = None) + (env : fmt_env) (inside : bool) (indent : string) (indent_incr : string) + (e : texpression) : string = match e.e with | Var var_id -> var_id_to_string env var_id | CVar cg_id -> const_generic_var_id_to_string env cg_id @@ -541,10 +552,14 @@ let rec texpression_to_string ?(metadata : Meta.meta option = None) (env : fmt_e (* Qualifier without arguments *) app_to_string ~meta:metadata env inside indent indent_incr e [] | Let (monadic, lv, re, e) -> - let e = let_to_string ~meta:metadata env indent indent_incr monadic lv re e in + let e = + let_to_string ~meta:metadata env indent indent_incr monadic lv re e + in if inside then "(" ^ e ^ ")" else e | Switch (scrutinee, body) -> - let e = switch_to_string ~meta:metadata env indent indent_incr scrutinee body in + let e = + switch_to_string ~meta:metadata env indent indent_incr scrutinee body + in if inside then "(" ^ e ^ ")" else e | Loop loop -> let e = loop_to_string ~meta:metadata env indent indent_incr loop in @@ -566,7 +581,8 @@ let rec texpression_to_string ?(metadata : Meta.meta option = None) (env : fmt_e (fun (fid, fe) -> let field = FieldId.nth field_names fid in let fe = - texpression_to_string ~metadata:metadata env false indent2 indent_incr fe + texpression_to_string ~metadata env false indent2 indent_incr + fe in "\n" ^ indent1 ^ field ^ " := " ^ fe ^ ";") supd.updates @@ -577,23 +593,23 @@ let rec texpression_to_string ?(metadata : Meta.meta option = None) (env : fmt_e let fields = List.map (fun (_, fe) -> - texpression_to_string ~metadata:metadata env false indent2 indent_incr fe) + texpression_to_string ~metadata env false indent2 indent_incr fe) supd.updates in "[ " ^ String.concat ", " fields ^ " ]" | _ -> craise_opt_meta metadata "Unexpected") | Meta (meta, e) -> ( - let meta_s = emeta_to_string ~metadata:metadata env meta in - let e = texpression_to_string ~metadata:metadata env inside indent indent_incr e in + let meta_s = emeta_to_string ~metadata env meta in + let e = texpression_to_string ~metadata env inside indent indent_incr e in match meta with | Assignment _ | SymbolicAssignments _ | SymbolicPlaces _ | Tag _ -> let e = meta_s ^ "\n" ^ indent ^ e in if inside then "(" ^ e ^ ")" else e | MPlace _ -> "(" ^ meta_s ^ " " ^ e ^ ")") -and app_to_string ?(meta : Meta.meta option = None) (env : fmt_env) (inside : bool) (indent : string) - (indent_incr : string) (app : texpression) (args : texpression list) : - string = +and app_to_string ?(meta : Meta.meta option = None) (env : fmt_env) + (inside : bool) (indent : string) (indent_incr : string) (app : texpression) + (args : texpression list) : string = (* There are two possibilities: either the [app] is an instantiated, * top-level qualifier (function, ADT constructore...), or it is a "regular" * expression *) @@ -611,13 +627,13 @@ and app_to_string ?(meta : Meta.meta option = None) (env : fmt_env) (inside : bo (global_decl_id_to_string env global_id, generics) | AdtCons adt_cons_id -> let variant_s = - adt_variant_to_string ~meta:meta env adt_cons_id.adt_id + adt_variant_to_string ~meta env adt_cons_id.adt_id adt_cons_id.variant_id in (ConstStrings.constructor_prefix ^ variant_s, []) | Proj { adt_id; field_id } -> - let adt_s = adt_variant_to_string ~meta:meta env adt_id None in - let field_s = adt_field_to_string ~meta:meta env adt_id field_id in + let adt_s = adt_variant_to_string ~meta env adt_id None in + let field_s = adt_field_to_string ~meta env adt_id field_id in (* Adopting an F*-like syntax *) (ConstStrings.constructor_prefix ^ adt_s ^ "?." ^ field_s, []) | TraitConst (trait_ref, const_name) -> @@ -627,7 +643,8 @@ and app_to_string ?(meta : Meta.meta option = None) (env : fmt_env) (inside : bo | _ -> (* "Regular" expression case *) let inside = args <> [] || (args = [] && inside) in - (texpression_to_string ~metadata:meta env inside indent indent_incr app, []) + ( texpression_to_string ~metadata:meta env inside indent indent_incr app, + [] ) in (* Convert the arguments. * The arguments are expressions, so indentation might get weird... (though @@ -646,31 +663,41 @@ and app_to_string ?(meta : Meta.meta option = None) (env : fmt_env) (inside : bo (* Add parentheses *) if all_args <> [] && inside then "(" ^ e ^ ")" else e -and lambda_to_string ?(meta : Meta.meta option = None) (env : fmt_env) (indent : string) (indent_incr : string) - (xl : typed_pattern list) (e : texpression) : string = - let xl = List.map (typed_pattern_to_string ~meta:meta env) xl in +and lambda_to_string ?(meta : Meta.meta option = None) (env : fmt_env) + (indent : string) (indent_incr : string) (xl : typed_pattern list) + (e : texpression) : string = + let xl = List.map (typed_pattern_to_string ~meta env) xl in let e = texpression_to_string ~metadata:meta env false indent indent_incr e in "λ " ^ String.concat " " xl ^ ". " ^ e -and let_to_string ?(meta : Meta.meta option = None) (env : fmt_env) (indent : string) (indent_incr : string) - (monadic : bool) (lv : typed_pattern) (re : texpression) (e : texpression) : - string = +and let_to_string ?(meta : Meta.meta option = None) (env : fmt_env) + (indent : string) (indent_incr : string) (monadic : bool) + (lv : typed_pattern) (re : texpression) (e : texpression) : string = let indent1 = indent ^ indent_incr in let inside = false in - let re = texpression_to_string ~metadata:meta env inside indent1 indent_incr re in - let e = texpression_to_string ~metadata:meta env inside indent indent_incr e in - let lv = typed_pattern_to_string ~meta:meta env lv in + let re = + texpression_to_string ~metadata:meta env inside indent1 indent_incr re + in + let e = + texpression_to_string ~metadata:meta env inside indent indent_incr e + in + let lv = typed_pattern_to_string ~meta env lv in if monadic then lv ^ " <-- " ^ re ^ ";\n" ^ indent ^ e else "let " ^ lv ^ " = " ^ re ^ " in\n" ^ indent ^ e -and switch_to_string ?(meta : Meta.meta option = None) (env : fmt_env) (indent : string) (indent_incr : string) - (scrutinee : texpression) (body : switch_body) : string = +and switch_to_string ?(meta : Meta.meta option = None) (env : fmt_env) + (indent : string) (indent_incr : string) (scrutinee : texpression) + (body : switch_body) : string = let indent1 = indent ^ indent_incr in (* Printing can mess up on the scrutinee, because it is an expression - but * in most situations it will be a value or a function call, so it should be * ok*) - let scrut = texpression_to_string ~metadata:meta env true indent1 indent_incr scrutinee in - let e_to_string = texpression_to_string ~metadata:meta env false indent1 indent_incr in + let scrut = + texpression_to_string ~metadata:meta env true indent1 indent_incr scrutinee + in + let e_to_string = + texpression_to_string ~metadata:meta env false indent1 indent_incr + in match body with | If (e_true, e_false) -> let e_true = e_to_string e_true in @@ -679,14 +706,14 @@ and switch_to_string ?(meta : Meta.meta option = None) (env : fmt_env) (indent : ^ indent ^ "else\n" ^ indent1 ^ e_false | Match branches -> let branch_to_string (b : match_branch) : string = - let pat = typed_pattern_to_string ~meta:meta env b.pat in + let pat = typed_pattern_to_string ~meta env b.pat in indent ^ "| " ^ pat ^ " ->\n" ^ indent1 ^ e_to_string b.branch in let branches = List.map branch_to_string branches in "match " ^ scrut ^ " with\n" ^ String.concat "\n" branches -and loop_to_string ?(meta : Meta.meta option = None) (env : fmt_env) (indent : string) (indent_incr : string) - (loop : loop) : string = +and loop_to_string ?(meta : Meta.meta option = None) (env : fmt_env) + (indent : string) (indent_incr : string) (loop : loop) : string = let indent1 = indent ^ indent_incr in let indent2 = indent1 ^ indent_incr in let loop_inputs = @@ -696,17 +723,20 @@ and loop_to_string ?(meta : Meta.meta option = None) (env : fmt_env) (indent : s in let output_ty = "output_ty: " ^ ty_to_string env false loop.output_ty in let fun_end = - texpression_to_string ~metadata:meta env false indent2 indent_incr loop.fun_end + texpression_to_string ~metadata:meta env false indent2 indent_incr + loop.fun_end in let loop_body = - texpression_to_string ~metadata:meta env false indent2 indent_incr loop.loop_body + texpression_to_string ~metadata:meta env false indent2 indent_incr + loop.loop_body in "loop {\n" ^ indent1 ^ loop_inputs ^ "\n" ^ indent1 ^ output_ty ^ "\n" ^ indent1 ^ "fun_end: {\n" ^ indent2 ^ fun_end ^ "\n" ^ indent1 ^ "}\n" ^ indent1 ^ "loop_body: {\n" ^ indent2 ^ loop_body ^ "\n" ^ indent1 ^ "}\n" ^ indent ^ "}" -and emeta_to_string ?(metadata : Meta.meta option = None) (env : fmt_env) (meta : emeta) : string = +and emeta_to_string ?(metadata : Meta.meta option = None) (env : fmt_env) + (meta : emeta) : string = let meta = match meta with | Assignment (lp, rv, rp) -> @@ -716,14 +746,14 @@ and emeta_to_string ?(metadata : Meta.meta option = None) (env : fmt_env) (meta | Some rp -> " [@src=" ^ mplace_to_string env rp ^ "]" in "@assign(" ^ mplace_to_string env lp ^ " := " - ^ texpression_to_string ~metadata:metadata env false "" "" rv + ^ texpression_to_string ~metadata env false "" "" rv ^ rp ^ ")" | SymbolicAssignments info -> let infos = List.map (fun (var_id, rv) -> VarId.to_string var_id ^ " == " - ^ texpression_to_string ~metadata:metadata env false "" "" rv) + ^ texpression_to_string ~metadata env false "" "" rv) info in let infos = String.concat ", " infos in @@ -756,5 +786,8 @@ let fun_decl_to_string (env : fmt_env) (def : fun_decl) : string = if inputs = [] then indent else " fun " ^ String.concat " " inputs ^ " ->\n" ^ indent in - let body = texpression_to_string ~metadata:(Some def.meta) env inside indent indent body.body in + let body = + texpression_to_string ~metadata:(Some def.meta) env inside indent indent + body.body + in "let " ^ name ^ " :\n " ^ signature ^ " =\n" ^ inputs ^ body diff --git a/compiler/PureMicroPasses.ml b/compiler/PureMicroPasses.ml index ab4686c9..e58b318a 100644 --- a/compiler/PureMicroPasses.ml +++ b/compiler/PureMicroPasses.ml @@ -1240,10 +1240,11 @@ let simplify_aggregates (ctx : trans_ctx) (def : fun_decl) : fun_decl = if List.for_all (fun (_, y) -> y = x) end_args then ( (* We can substitute *) (* Sanity check: all types correct *) - sanity_check ( - List.for_all - (fun (generics1, _) -> generics1 = generics) - args) def.meta; + sanity_check + (List.for_all + (fun (generics1, _) -> generics1 = generics) + args) + def.meta; { e with e = Var x }) else super#visit_texpression env e else super#visit_texpression env e @@ -1398,7 +1399,9 @@ let decompose_loops (_ctx : trans_ctx) (def : fun_decl) : { fwd_info; effect_info = loop_fwd_effect_info; ignore_output } in - cassert (fun_sig_info_is_wf loop_fwd_sig_info) def.meta "TODO: error message"; + cassert + (fun_sig_info_is_wf loop_fwd_sig_info) + def.meta "TODO: error message"; let inputs_tys = let fuel = if !Config.use_fuel then [ mk_fuel_ty ] else [] in @@ -1438,9 +1441,10 @@ let decompose_loops (_ctx : trans_ctx) (def : fun_decl) : (* Introduce the forward input state *) let fwd_state_var, fwd_state_lvs = - cassert ( - loop_fwd_effect_info.stateful - = Option.is_some loop.input_state) def.meta "TODO: error message"; + cassert + (loop_fwd_effect_info.stateful + = Option.is_some loop.input_state) + def.meta "TODO: error message"; match loop.input_state with | None -> ([], []) | Some input_state -> @@ -1477,7 +1481,8 @@ let decompose_loops (_ctx : trans_ctx) (def : fun_decl) : match fuel_vars with | None -> loop.loop_body | Some (fuel0, fuel) -> - SymbolicToPure.wrap_in_match_fuel def.meta fuel0 fuel loop.loop_body + SymbolicToPure.wrap_in_match_fuel def.meta fuel0 fuel + loop.loop_body in let loop_body = { inputs; inputs_lvs; body = loop_body } in diff --git a/compiler/PureTypeCheck.ml b/compiler/PureTypeCheck.ml index d2fa57ae..7576af90 100644 --- a/compiler/PureTypeCheck.ml +++ b/compiler/PureTypeCheck.ml @@ -9,9 +9,9 @@ open Errors This function should only be used for "regular" ADTs, where the number of fields is fixed: it shouldn't be used for arrays, slices, etc. *) -let get_adt_field_types (meta : Meta.meta) (type_decls : type_decl TypeDeclId.Map.t) - (type_id : type_id) (variant_id : VariantId.id option) - (generics : generic_args) : ty list = +let get_adt_field_types (meta : Meta.meta) + (type_decls : type_decl TypeDeclId.Map.t) (type_id : type_id) + (variant_id : VariantId.id option) (generics : generic_args) : ty list = match type_id with | TTuple -> (* Tuple *) @@ -34,13 +34,13 @@ let get_adt_field_types (meta : Meta.meta) (type_decls : type_decl TypeDeclId.Ma let variant_id = Option.get variant_id in if variant_id = result_return_id then [ ty ] else if variant_id = result_fail_id then [ mk_error_ty ] - else - craise meta "Unreachable: improper variant id for result type" + else craise meta "Unreachable: improper variant id for result type" | TError -> sanity_check (generics = empty_generic_args) meta; let variant_id = Option.get variant_id in - sanity_check ( - variant_id = error_failure_id || variant_id = error_out_of_fuel_id) meta; + sanity_check + (variant_id = error_failure_id || variant_id = error_out_of_fuel_id) + meta; [] | TFuel -> let variant_id = Option.get variant_id in @@ -68,7 +68,8 @@ let check_literal (meta : Meta.meta) (v : literal) (ty : literal_type) : unit = | TBool, VBool _ | TChar, VChar _ -> () | _ -> craise meta "Inconsistent type" -let rec check_typed_pattern (meta : Meta.meta) (ctx : tc_ctx) (v : typed_pattern) : tc_ctx = +let rec check_typed_pattern (meta : Meta.meta) (ctx : tc_ctx) + (v : typed_pattern) : tc_ctx = log#ldebug (lazy ("check_typed_pattern: " ^ show_typed_pattern v)); match v.value with | PatConstant cv -> @@ -101,7 +102,8 @@ let rec check_typed_pattern (meta : Meta.meta) (ctx : tc_ctx) (v : typed_pattern ctx (List.combine field_tys av.field_values) -let rec check_texpression (meta : Meta.meta) (ctx : tc_ctx) (e : texpression) : unit = +let rec check_texpression (meta : Meta.meta) (ctx : tc_ctx) (e : texpression) : + unit = match e.e with | Var var_id -> ( (* Lookup the variable - note that the variable may not be there, @@ -162,7 +164,9 @@ let rec check_texpression (meta : Meta.meta) (ctx : tc_ctx) (e : texpression) : sanity_check (generics = qualif.generics) meta | _ -> craise meta "Unreachable")) | Let (monadic, pat, re, e_next) -> - let expected_pat_ty = if monadic then destruct_result meta re.ty else re.ty in + let expected_pat_ty = + if monadic then destruct_result meta re.ty else re.ty + in sanity_check (pat.ty = expected_pat_ty) meta; sanity_check (e.ty = e_next.ty) meta; (* Check the right-expression *) @@ -206,7 +210,8 @@ let rec check_texpression (meta : Meta.meta) (ctx : tc_ctx) (e : texpression) : | TAdtId _ -> let variant_id = None in let expected_field_tys = - get_adt_field_types meta ctx.type_decls adt_id variant_id adt_generics + get_adt_field_types meta ctx.type_decls adt_id variant_id + adt_generics in List.iter (fun ((fid, fe) : _ * texpression) -> diff --git a/compiler/PureUtils.ml b/compiler/PureUtils.ml index cce70382..328f757a 100644 --- a/compiler/PureUtils.ml +++ b/compiler/PureUtils.ml @@ -214,7 +214,8 @@ let fun_sig_substitute (subst : subst) (sg : fun_sig) : inst_fun_sig = Rem.: this function will *fail* if there are {!Pure.Loop} nodes (you should call it on an expression where those nodes have been eliminated). *) -let rec let_group_requires_parentheses (meta : Meta.meta) (e : texpression) : bool = +let rec let_group_requires_parentheses (meta : Meta.meta) (e : texpression) : + bool = match e.e with | Var _ | CVar _ | Const _ | App _ | Qualif _ | StructUpdate _ -> false | Let (monadic, _, _, next_e) -> @@ -321,7 +322,8 @@ let destruct_apps (e : texpression) : texpression * texpression list = aux [] e (** Make an [App (app, arg)] expression *) -let mk_app (meta : Meta.meta) (app : texpression) (arg : texpression) : texpression = +let mk_app (meta : Meta.meta) (app : texpression) (arg : texpression) : + texpression = let raise_or_return msg = save_error (Some meta) msg; let e = App (app, arg) in @@ -343,7 +345,8 @@ let mk_app (meta : Meta.meta) (app : texpression) (arg : texpression) : texpress | _ -> raise_or_return "Expected an arrow type" (** The reverse of {!destruct_apps} *) -let mk_apps (meta : Meta.meta) (app : texpression) (args : texpression list) : texpression = +let mk_apps (meta : Meta.meta) (app : texpression) (args : texpression list) : + texpression = List.fold_left (fun app arg -> mk_app meta app arg) app args (** Destruct an expression into a qualif identifier and a list of arguments, @@ -375,7 +378,8 @@ let opt_destruct_result (meta : Meta.meta) (ty : ty) : ty option = Some (Collections.List.to_cons_nil generics.types) | _ -> None -let destruct_result (meta : Meta.meta) (ty : ty) : ty = Option.get (opt_destruct_result meta ty) +let destruct_result (meta : Meta.meta) (ty : ty) : ty = + Option.get (opt_destruct_result meta ty) let opt_destruct_tuple (meta : Meta.meta) (ty : ty) : ty list option = match ty with @@ -422,7 +426,8 @@ let iter_switch_body_branches (f : texpression -> unit) (sb : switch_body) : f e_else | Match branches -> List.iter (fun (b : match_branch) -> f b.branch) branches -let mk_switch (meta : Meta.meta) (scrut : texpression) (sb : switch_body) : texpression = +let mk_switch (meta : Meta.meta) (scrut : texpression) (sb : switch_body) : + texpression = (* Sanity check: the scrutinee has the proper type *) (match sb with | If (_, _) -> sanity_check (scrut.ty = TLiteral TBool) meta @@ -497,7 +502,8 @@ let mk_simpl_tuple_pattern (vl : typed_pattern list) : typed_pattern = { value; ty } (** Similar to {!mk_simpl_tuple_pattern} *) -let mk_simpl_tuple_texpression (meta : Meta.meta) (vl : texpression list) : texpression = +let mk_simpl_tuple_texpression (meta : Meta.meta) (vl : texpression list) : + texpression = match vl with | [ v ] -> v | _ -> @@ -548,7 +554,8 @@ let unwrap_result_ty (meta : Meta.meta) (ty : ty) : ty = ty | _ -> craise meta "not a result type" -let mk_result_fail_texpression (meta : Meta.meta) (error : texpression) (ty : ty) : texpression = +let mk_result_fail_texpression (meta : Meta.meta) (error : texpression) + (ty : ty) : texpression = let type_args = [ ty ] in let ty = TAdt (TAssumed TResult, mk_generic_args_from_types type_args) in let id = @@ -560,12 +567,13 @@ let mk_result_fail_texpression (meta : Meta.meta) (error : texpression) (ty : ty let cons = { e = cons_e; ty = cons_ty } in mk_app meta cons error -let mk_result_fail_texpression_with_error_id (meta : Meta.meta) (error : VariantId.id) (ty : ty) : - texpression = +let mk_result_fail_texpression_with_error_id (meta : Meta.meta) + (error : VariantId.id) (ty : ty) : texpression = let error = mk_error error in mk_result_fail_texpression meta error ty -let mk_result_return_texpression (meta : Meta.meta) (v : texpression) : texpression = +let mk_result_return_texpression (meta : Meta.meta) (v : texpression) : + texpression = let type_args = [ v.ty ] in let ty = TAdt (TAssumed TResult, mk_generic_args_from_types type_args) in let id = @@ -613,15 +621,17 @@ let mk_fuel_var (id : VarId.id) : var = let mk_fuel_texpression (id : VarId.id) : texpression = { e = Var id; ty = mk_fuel_ty } -let rec typed_pattern_to_texpression (meta : Meta.meta) (pat : typed_pattern) : texpression option - = +let rec typed_pattern_to_texpression (meta : Meta.meta) (pat : typed_pattern) : + texpression option = let e_opt = match pat.value with | PatConstant pv -> Some (Const pv) | PatVar (v, _) -> Some (Var v.id) | PatDummy -> None | PatAdt av -> - let fields = List.map (typed_pattern_to_texpression meta) av.field_values in + let fields = + List.map (typed_pattern_to_texpression meta) av.field_values + in if List.mem None fields then None else let fields_values = List.map (fun e -> Option.get e) fields in diff --git a/compiler/RegionsHierarchy.ml b/compiler/RegionsHierarchy.ml index a4d66854..7267dd3d 100644 --- a/compiler/RegionsHierarchy.ml +++ b/compiler/RegionsHierarchy.ml @@ -40,7 +40,8 @@ module Subst = Substitute (** The local logger *) let log = Logging.regions_hierarchy_log -let compute_regions_hierarchy_for_sig (meta : Meta.meta option) (type_decls : type_decl TypeDeclId.Map.t) +let compute_regions_hierarchy_for_sig (meta : Meta.meta option) + (type_decls : type_decl TypeDeclId.Map.t) (fun_decls : fun_decl FunDeclId.Map.t) (global_decls : global_decl GlobalDeclId.Map.t) (trait_decls : trait_decl TraitDeclId.Map.t) @@ -51,11 +52,11 @@ let compute_regions_hierarchy_for_sig (meta : Meta.meta option) (type_decls : ty associated types) *) let norm_ctx : AssociatedTypes.norm_ctx = let norm_trait_types = - AssociatedTypes.compute_norm_trait_types_from_preds meta + AssociatedTypes.compute_norm_trait_types_from_preds meta sg.preds.trait_type_constraints in { - meta = meta; + meta; norm_trait_types; type_decls; fun_decls; @@ -174,13 +175,15 @@ let compute_regions_hierarchy_for_sig (meta : Meta.meta option) (type_decls : ty | TTraitType (trait_ref, _) -> (* The trait should reference a clause, and not an implementation (otherwise it should have been normalized) *) - sanity_check_opt_meta ( - AssociatedTypes.trait_instance_id_is_local_clause trait_ref.trait_id) meta; + sanity_check_opt_meta + (AssociatedTypes.trait_instance_id_is_local_clause trait_ref.trait_id) + meta; (* We have nothing to do *) () | TArrow (regions, inputs, output) -> (* TODO: *) - cassert_opt_meta (regions = []) meta "We don't support arrow types with locally quantified regions"; + cassert_opt_meta (regions = []) meta + "We don't support arrow types with locally quantified regions"; (* We can ignore the outer regions *) List.iter (explore_ty []) (output :: inputs) and explore_generics (outer : region list) (generics : generic_args) = @@ -319,7 +322,8 @@ let compute_regions_hierarchies (type_decls : type_decl TypeDeclId.Map.t) let regular = List.map (fun ((fid, d) : FunDeclId.id * fun_decl) -> - (FRegular fid, (Types.name_to_string env d.name, d.signature, Some d.meta))) + ( FRegular fid, + (Types.name_to_string env d.name, d.signature, Some d.meta) )) (FunDeclId.Map.bindings fun_decls) in let assumed = @@ -332,6 +336,6 @@ let compute_regions_hierarchies (type_decls : type_decl TypeDeclId.Map.t) (List.map (fun (fid, (name, sg, meta)) -> ( fid, - compute_regions_hierarchy_for_sig meta type_decls fun_decls global_decls - trait_decls trait_impls name sg)) + compute_regions_hierarchy_for_sig meta type_decls fun_decls + global_decls trait_decls trait_impls name sg )) (regular @ assumed)) diff --git a/compiler/Substitute.ml b/compiler/Substitute.ml index 14cda863..182dfabf 100644 --- a/compiler/Substitute.ml +++ b/compiler/Substitute.ml @@ -68,14 +68,16 @@ let ctx_adt_get_instantiated_field_types (ctx : eval_ctx) **IMPORTANT**: this function doesn't normalize the types, you may want to use the [AssociatedTypes] equivalent instead. *) -let ctx_adt_value_get_instantiated_field_types (meta : Meta.meta) (ctx : eval_ctx) - (adt : adt_value) (id : type_id) (generics : generic_args) : ty list = +let ctx_adt_value_get_instantiated_field_types (meta : Meta.meta) + (ctx : eval_ctx) (adt : adt_value) (id : type_id) (generics : generic_args) + : ty list = match id with | TAdtId id -> (* Retrieve the types of the fields *) ctx_adt_get_instantiated_field_types ctx id adt.variant_id generics | TTuple -> - cassert (generics.regions = []) meta "Regions should be empty TODO: error message"; + cassert (generics.regions = []) meta + "Regions should be empty TODO: error message"; generics.types | TAssumed aty -> ( match aty with @@ -145,7 +147,8 @@ let subst_ids_visitor (r_subst : RegionId.id -> RegionId.id) method! visit_abstraction_id _ id = asubst id end -let typed_value_subst_ids (meta : Meta.meta) (r_subst : RegionId.id -> RegionId.id) +let typed_value_subst_ids (meta : Meta.meta) + (r_subst : RegionId.id -> RegionId.id) (ty_subst : TypeVarId.id -> TypeVarId.id) (cg_subst : ConstGenericVarId.id -> ConstGenericVarId.id) (ssubst : SymbolicValueId.id -> SymbolicValueId.id) @@ -154,8 +157,8 @@ let typed_value_subst_ids (meta : Meta.meta) (r_subst : RegionId.id -> RegionId. 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 (meta : Meta.meta) (r_subst : RegionId.id -> RegionId.id) - (v : typed_value) : typed_value = +let typed_value_subst_rids (meta : Meta.meta) + (r_subst : RegionId.id -> RegionId.id) (v : typed_value) : typed_value = typed_value_subst_ids meta r_subst (fun x -> x) (fun x -> x) @@ -163,7 +166,8 @@ let typed_value_subst_rids (meta : Meta.meta) (r_subst : RegionId.id -> RegionId (fun x -> x) v -let typed_avalue_subst_ids (meta : Meta.meta) (r_subst : RegionId.id -> RegionId.id) +let typed_avalue_subst_ids (meta : Meta.meta) + (r_subst : RegionId.id -> RegionId.id) (ty_subst : TypeVarId.id -> TypeVarId.id) (cg_subst : ConstGenericVarId.id -> ConstGenericVarId.id) (ssubst : SymbolicValueId.id -> SymbolicValueId.id) @@ -190,8 +194,8 @@ let env_subst_ids (r_subst : RegionId.id -> RegionId.id) let vis = subst_ids_visitor r_subst ty_subst cg_subst ssubst bsubst asubst in vis#visit_env () x -let typed_avalue_subst_rids (meta : Meta.meta) (r_subst : RegionId.id -> RegionId.id) - (x : typed_avalue) : typed_avalue = +let typed_avalue_subst_rids (meta : Meta.meta) + (r_subst : RegionId.id -> RegionId.id) (x : typed_avalue) : typed_avalue = let asubst _ = craise meta "Unreachable" in let vis = subst_ids_visitor r_subst diff --git a/compiler/SymbolicToPure.ml b/compiler/SymbolicToPure.ml index 3532b2dd..db32c2ce 100644 --- a/compiler/SymbolicToPure.ml +++ b/compiler/SymbolicToPure.ml @@ -349,7 +349,8 @@ let pure_type_decl_to_string (ctx : bs_ctx) (def : type_decl) : string = let texpression_to_string (ctx : bs_ctx) (e : texpression) : string = let env = bs_ctx_to_pure_fmt_env ctx in - PrintPure.texpression_to_string ~metadata:(Some ctx.fun_decl.meta) env false "" " " e + PrintPure.texpression_to_string ~metadata:(Some ctx.fun_decl.meta) env false + "" " " e let fun_id_to_string (ctx : bs_ctx) (id : A.fun_id) : string = let env = bs_ctx_to_fmt_env ctx in @@ -363,9 +364,10 @@ let fun_decl_to_string (ctx : bs_ctx) (def : Pure.fun_decl) : string = let env = bs_ctx_to_pure_fmt_env ctx in PrintPure.fun_decl_to_string env def -let typed_pattern_to_string ?(meta : Meta.meta option = None) (ctx : bs_ctx) (p : Pure.typed_pattern) : string = +let typed_pattern_to_string ?(meta : Meta.meta option = None) (ctx : bs_ctx) + (p : Pure.typed_pattern) : string = let env = bs_ctx_to_pure_fmt_env ctx in - PrintPure.typed_pattern_to_string ~meta:meta env p + PrintPure.typed_pattern_to_string ~meta env p let ctx_get_effect_info_for_bid (ctx : bs_ctx) (bid : RegionGroupId.id option) : fun_effect_info = @@ -384,7 +386,8 @@ let abs_to_string (ctx : bs_ctx) (abs : V.abs) : string = let verbose = false in let indent = "" in let indent_incr = " " in - Print.Values.abs_to_string ~meta:(Some ctx.fun_decl.meta) env verbose indent indent_incr abs + Print.Values.abs_to_string ~meta:(Some ctx.fun_decl.meta) env verbose indent + indent_incr abs let bs_ctx_lookup_llbc_type_decl (id : TypeDeclId.id) (ctx : bs_ctx) : T.type_decl = @@ -407,8 +410,8 @@ let rec translate_generic_args (meta : Meta.meta) (translate_ty : T.ty -> ty) in { types; const_generics; trait_refs } -and translate_trait_ref (meta : Meta.meta) (translate_ty : T.ty -> ty) (tr : T.trait_ref) : - trait_ref = +and translate_trait_ref (meta : Meta.meta) (translate_ty : T.ty -> ty) + (tr : T.trait_ref) : trait_ref = let trait_id = translate_trait_instance_id meta translate_ty tr.trait_id in let generics = translate_generic_args meta translate_ty tr.generics in let trait_decl_ref = @@ -416,14 +419,18 @@ and translate_trait_ref (meta : Meta.meta) (translate_ty : T.ty -> ty) (tr : T.t in { trait_id; generics; trait_decl_ref } -and translate_trait_decl_ref (meta : Meta.meta) (translate_ty : T.ty -> ty) (tr : T.trait_decl_ref) - : trait_decl_ref = - let decl_generics = translate_generic_args meta translate_ty tr.decl_generics in +and translate_trait_decl_ref (meta : Meta.meta) (translate_ty : T.ty -> ty) + (tr : T.trait_decl_ref) : trait_decl_ref = + let decl_generics = + translate_generic_args meta translate_ty tr.decl_generics + in { trait_decl_id = tr.trait_decl_id; decl_generics } and translate_trait_instance_id (meta : Meta.meta) (translate_ty : T.ty -> ty) (id : T.trait_instance_id) : trait_instance_id = - let translate_trait_instance_id = translate_trait_instance_id meta translate_ty in + let translate_trait_instance_id = + translate_trait_instance_id meta translate_ty + in match id with | T.Self -> Self | TraitImpl id -> TraitImpl id @@ -459,10 +466,8 @@ let rec translate_sty (meta : Meta.meta) (ty : T.ty) : ty = match generics.types with | [ ty ] -> ty | _ -> - craise - meta - "Box/vec/option type with incorrect number of arguments" - ) + craise meta + "Box/vec/option type with incorrect number of arguments") | T.TArray -> TAdt (TAssumed TArray, generics) | T.TSlice -> TAdt (TAssumed TSlice, generics) | T.TStr -> TAdt (TAssumed TStr, generics))) @@ -480,35 +485,41 @@ let rec translate_sty (meta : Meta.meta) (ty : T.ty) : ty = TTraitType (trait_ref, type_name) | TArrow _ -> craise meta "TODO: error message" -and translate_sgeneric_args (meta : Meta.meta) (generics : T.generic_args) : generic_args = +and translate_sgeneric_args (meta : Meta.meta) (generics : T.generic_args) : + generic_args = translate_generic_args meta (translate_sty meta) generics and translate_strait_ref (meta : Meta.meta) (tr : T.trait_ref) : trait_ref = translate_trait_ref meta (translate_sty meta) tr -and translate_strait_instance_id (meta : Meta.meta) (id : T.trait_instance_id) : trait_instance_id - = +and translate_strait_instance_id (meta : Meta.meta) (id : T.trait_instance_id) : + trait_instance_id = translate_trait_instance_id meta (translate_sty meta) id -let translate_trait_clause (meta : Meta.meta) (clause : T.trait_clause) : trait_clause = +let translate_trait_clause (meta : Meta.meta) (clause : T.trait_clause) : + trait_clause = let { T.clause_id; meta = _; trait_id; clause_generics } = clause in let generics = translate_sgeneric_args meta clause_generics in { clause_id; trait_id; generics } -let translate_strait_type_constraint (meta : Meta.meta) (ttc : T.trait_type_constraint) : - trait_type_constraint = +let translate_strait_type_constraint (meta : Meta.meta) + (ttc : T.trait_type_constraint) : trait_type_constraint = let { T.trait_ref; type_name; ty } = ttc in let trait_ref = translate_strait_ref meta trait_ref in let ty = translate_sty meta ty in { trait_ref; type_name; ty } -let translate_predicates (meta : Meta.meta) (preds : T.predicates) : predicates = +let translate_predicates (meta : Meta.meta) (preds : T.predicates) : predicates + = let trait_type_constraints = - List.map (translate_strait_type_constraint meta) preds.trait_type_constraints + List.map + (translate_strait_type_constraint meta) + preds.trait_type_constraints in { trait_type_constraints } -let translate_generic_params (meta : Meta.meta) (generics : T.generic_params) : generic_params = +let translate_generic_params (meta : Meta.meta) (generics : T.generic_params) : + generic_params = let { T.regions = _; types; const_generics; trait_clauses } = generics in let trait_clauses = List.map (translate_trait_clause meta) trait_clauses in { types; const_generics; trait_clauses } @@ -530,7 +541,8 @@ let translate_variants (meta : Meta.meta) (vl : T.variant list) : variant list = List.map (translate_variant meta) vl (** Translate a type def kind from LLBC *) -let translate_type_decl_kind (meta : Meta.meta) (kind : T.type_decl_kind) : type_decl_kind = +let translate_type_decl_kind (meta : Meta.meta) (kind : T.type_decl_kind) : + type_decl_kind = match kind with | T.Struct fields -> Struct (translate_fields meta fields) | T.Enum variants -> Enum (translate_variants meta variants) @@ -555,8 +567,11 @@ let translate_type_decl (ctx : Contexts.decls_ctx) (def : T.type_decl) : let name = Print.Types.name_to_string env def.name in let { T.regions; types; const_generics; trait_clauses } = def.generics in (* Can't translate types with regions for now *) - cassert (regions = []) def.meta "ADTs containing borrows are not supported yet"; - let trait_clauses = List.map (translate_trait_clause def.meta) trait_clauses in + cassert (regions = []) def.meta + "ADTs containing borrows are not supported yet"; + let trait_clauses = + List.map (translate_trait_clause def.meta) trait_clauses + in let generics = { types; const_generics; trait_clauses } in let kind = translate_type_decl_kind def.meta def.T.kind in let preds = translate_predicates def.meta def.preds in @@ -599,7 +614,8 @@ let translate_type_id (meta : Meta.meta) (id : T.type_id) : type_id = TODO: factor out the various translation functions. *) -let rec translate_fwd_ty (meta : Meta.meta) (type_infos : type_infos) (ty : T.ty) : ty = +let rec translate_fwd_ty (meta : Meta.meta) (type_infos : type_infos) + (ty : T.ty) : ty = let translate = translate_fwd_ty meta type_infos in match ty with | T.TAdt (type_id, generics) -> ( @@ -616,18 +632,18 @@ let rec translate_fwd_ty (meta : Meta.meta) (type_infos : type_infos) (ty : T.ty | TAssumed TBox -> ( (* We eliminate boxes *) (* No general parametricity for now *) - cassert ( - not - (List.exists - (TypesUtils.ty_has_borrows type_infos) - generics.types)) meta "ADTs containing borrows are not supported yet"; + cassert + (not + (List.exists + (TypesUtils.ty_has_borrows type_infos) + generics.types)) + meta "ADTs containing borrows are not supported yet"; match t_generics.types with | [ bty ] -> bty | _ -> - craise - meta - "Unreachable: box/vec/option receives exactly one type \ - parameter")) + craise meta + "Unreachable: box/vec/option receives exactly one type \ + parameter")) | TVar vid -> TVar vid | TNever -> craise meta "Unreachable" | TLiteral lty -> TLiteral lty @@ -646,8 +662,8 @@ and translate_fwd_generic_args (meta : Meta.meta) (type_infos : type_infos) (generics : T.generic_args) : generic_args = translate_generic_args meta (translate_fwd_ty meta type_infos) generics -and translate_fwd_trait_ref (meta : Meta.meta) (type_infos : type_infos) (tr : T.trait_ref) : - trait_ref = +and translate_fwd_trait_ref (meta : Meta.meta) (type_infos : type_infos) + (tr : T.trait_ref) : trait_ref = translate_trait_ref meta (translate_fwd_ty meta type_infos) tr and translate_fwd_trait_instance_id (meta : Meta.meta) (type_infos : type_infos) @@ -685,7 +701,9 @@ let rec translate_back_ty (meta : Meta.meta) (type_infos : type_infos) 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 meta type_infos generics in + let generics = + translate_fwd_generic_args meta type_infos generics + in Some (TAdt (type_id, generics)) else (* If not inside a mutable reference: check if at least one @@ -696,19 +714,22 @@ let rec translate_back_ty (meta : Meta.meta) (type_infos : type_infos) *) let types = List.filter_map translate generics.types in if types <> [] then - let generics = translate_fwd_generic_args meta type_infos generics in + let generics = + translate_fwd_generic_args meta type_infos generics + in Some (TAdt (type_id, generics)) else None | TAssumed TBox -> ( (* Don't accept ADTs (which are not tuples) with borrows for now *) - cassert (not (TypesUtils.ty_has_borrows type_infos ty)) meta "ADTs containing borrows are not supported yet"; + cassert + (not (TypesUtils.ty_has_borrows type_infos ty)) + meta "ADTs containing borrows are not supported yet"; (* Eliminate the box *) match generics.types with | [ bty ] -> translate bty | _ -> - craise - meta "Unreachable: boxes receive exactly one type parameter" - ) + craise meta + "Unreachable: boxes receive exactly one type parameter") | TTuple -> ( (* Tuples can contain borrows (which we eliminate) *) let tys_t = List.filter_map translate generics.types in @@ -786,7 +807,9 @@ let translate_fun_id_or_trait_method_ref (ctx : bs_ctx) | FunId fun_id -> FunId fun_id | TraitMethod (trait_ref, method_name, fun_decl_id) -> let type_infos = ctx.type_ctx.type_infos in - let trait_ref = translate_fwd_trait_ref ctx.fun_decl.meta type_infos trait_ref in + let trait_ref = + translate_fwd_trait_ref ctx.fun_decl.meta type_infos trait_ref + in TraitMethod (trait_ref, method_name, fun_decl_id) let bs_ctx_register_forward_call (call_id : V.FunCallId.id) (forward : S.call) @@ -816,7 +839,9 @@ let bs_ctx_register_backward_call (abs : V.abs) (call_id : V.FunCallId.id) let calls = V.FunCallId.Map.add call_id info ctx.calls in (* Insert the abstraction in the abstractions map *) let abstractions = ctx.abstractions in - sanity_check (not (V.AbstractionId.Map.mem abs.abs_id abstractions)) ctx.fun_decl.meta; + sanity_check + (not (V.AbstractionId.Map.mem abs.abs_id abstractions)) + ctx.fun_decl.meta; let abstractions = V.AbstractionId.Map.add abs.abs_id (abs, back_args) abstractions in @@ -878,7 +903,8 @@ let mk_fuel_input_as_list (ctx : bs_ctx) (info : fun_effect_info) : if function_uses_fuel info then [ mk_fuel_texpression ctx.fuel ] else [] (** Small utility. *) -let compute_raw_fun_effect_info (meta : Meta.meta) (fun_infos : fun_info A.FunDeclId.Map.t) +let compute_raw_fun_effect_info (meta : Meta.meta) + (fun_infos : 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 @@ -921,7 +947,8 @@ let get_fun_effect_info (ctx : bs_ctx) (fun_id : A.fun_id_or_trait_method_ref) in { info with is_rec = info.is_rec || Option.is_some lid } | FunId (FAssumed _) -> - compute_raw_fun_effect_info ctx.fun_decl.meta ctx.fun_ctx.fun_infos fun_id lid gid) + compute_raw_fun_effect_info ctx.fun_decl.meta ctx.fun_ctx.fun_infos + fun_id lid gid) | Some lid -> ( (* This is necessarily for the current function *) match fun_id with @@ -1031,7 +1058,9 @@ let translate_fun_sig_with_regions_hierarchy_to_decomposed (meta : Meta.meta) (* For now we don't supported nested borrows, so we check that there aren't parent regions *) let parents = list_ancestor_region_groups regions_hierarchy gid in - cassert (T.RegionGroupId.Set.is_empty parents) meta "Nested borrows are not supported yet"; + cassert + (T.RegionGroupId.Set.is_empty parents) + meta "Nested borrows are not supported yet"; (* For now, we don't allow nested borrows, so the additional inputs to the backward function can only come from borrows that were returned like in (for the backward function we introduce for 'a): @@ -1477,13 +1506,13 @@ let lookup_var_for_symbolic_value (sv : V.symbolic_value) (ctx : bs_ctx) : var = match V.SymbolicValueId.Map.find_opt sv.sv_id ctx.sv_to_var with | Some v -> v | None -> - craise - ctx.fun_decl.meta - ("Could not find var for symbolic value: " - ^ V.SymbolicValueId.to_string sv.sv_id) + craise ctx.fun_decl.meta + ("Could not find var for symbolic value: " + ^ V.SymbolicValueId.to_string sv.sv_id) (** Peel boxes as long as the value is of the form [Box<T>] *) -let rec unbox_typed_value (meta : Meta.meta) (v : V.typed_value) : V.typed_value = +let rec unbox_typed_value (meta : Meta.meta) (v : V.typed_value) : V.typed_value + = match (v.value, v.ty) with | V.VAdt av, T.TAdt (T.TAssumed T.TBox, _) -> ( match av.field_values with @@ -1567,13 +1596,19 @@ let rec typed_value_to_texpression (ctx : bs_ctx) (ectx : C.eval_ctx) match bc with | VSharedBorrow bid -> (* Lookup the shared value in the context, and continue *) - let sv = InterpreterBorrowsCore.lookup_shared_value ctx.fun_decl.meta ectx bid in + let sv = + InterpreterBorrowsCore.lookup_shared_value ctx.fun_decl.meta ectx + bid + in translate sv | VReservedMutBorrow bid -> (* Same as for shared borrows. However, note that we use reserved borrows * only in *meta-data*: a value *actually used* in the translation can't come * from an unpromoted reserved borrow *) - let sv = InterpreterBorrowsCore.lookup_shared_value ctx.fun_decl.meta ectx bid in + let sv = + InterpreterBorrowsCore.lookup_shared_value ctx.fun_decl.meta ectx + bid + in translate sv | VMutBorrow (_, v) -> (* Borrows are the identity in the extraction *) @@ -1619,7 +1654,8 @@ let rec typed_avalue_to_consumed (ctx : bs_ctx) (ectx : C.eval_ctx) let adt_id, _ = TypesUtils.ty_as_adt av.ty in match adt_id with | TAdtId _ | TAssumed (TBox | TArray | TSlice | TStr) -> - cassert (field_values = []) ctx.fun_decl.meta "ADTs containing borrows are not supported yet"; + cassert (field_values = []) ctx.fun_decl.meta + "ADTs containing borrows are not supported yet"; None | TTuple -> (* Return *) @@ -1627,7 +1663,9 @@ let rec typed_avalue_to_consumed (ctx : bs_ctx) (ectx : C.eval_ctx) else (* Note that if there is exactly one field value, * [mk_simpl_tuple_rvalue] is the identity *) - let rv = mk_simpl_tuple_texpression ctx.fun_decl.meta field_values in + let rv = + mk_simpl_tuple_texpression ctx.fun_decl.meta field_values + in Some rv) | ABottom -> craise ctx.fun_decl.meta "Unreachable" | ALoan lc -> aloan_content_to_consumed ctx ectx lc @@ -1646,7 +1684,8 @@ let rec typed_avalue_to_consumed (ctx : bs_ctx) (ectx : C.eval_ctx) and aloan_content_to_consumed (ctx : bs_ctx) (ectx : C.eval_ctx) (lc : V.aloan_content) : texpression option = match lc with - | AMutLoan (_, _) | ASharedLoan (_, _, _) -> craise ctx.fun_decl.meta "Unreachable" + | AMutLoan (_, _) | ASharedLoan (_, _, _) -> + craise ctx.fun_decl.meta "Unreachable" | AEndedMutLoan { child = _; given_back = _; given_back_meta } -> (* Return the meta-value *) Some (typed_value_to_texpression ctx ectx given_back_meta) @@ -1762,7 +1801,8 @@ let rec typed_avalue_to_given_back (mp : mplace option) (av : V.typed_avalue) let adt_id, _ = TypesUtils.ty_as_adt av.ty in match adt_id with | TAdtId _ | TAssumed (TBox | TArray | TSlice | TStr) -> - cassert (field_values = []) ctx.fun_decl.meta "ADTs with borrows are not supported yet"; + cassert (field_values = []) ctx.fun_decl.meta + "ADTs with borrows are not supported yet"; (ctx, None) | TTuple -> (* Return *) @@ -1789,7 +1829,8 @@ let rec typed_avalue_to_given_back (mp : mplace option) (av : V.typed_avalue) and aloan_content_to_given_back (_mp : mplace option) (lc : V.aloan_content) (ctx : bs_ctx) : bs_ctx * typed_pattern option = match lc with - | AMutLoan (_, _) | ASharedLoan (_, _, _) -> craise ctx.fun_decl.meta "Unreachable" + | AMutLoan (_, _) | ASharedLoan (_, _, _) -> + craise ctx.fun_decl.meta "Unreachable" | AEndedMutLoan { child = _; given_back = _; given_back_meta = _ } | AEndedSharedLoan (_, _) -> (* We consider given back values, and thus ignore those *) @@ -1826,10 +1867,11 @@ and aproj_to_given_back (mp : mplace option) (aproj : V.aproj) (ctx : bs_ctx) : | V.AEndedProjLoans (_, child_projs) -> (* There may be children borrow projections in case of nested borrows, * in which case we need to dive in - we disallow nested borrows for now *) - cassert ( - List.for_all - (fun (_, aproj) -> aproj = V.AIgnoredProjBorrows) - child_projs) ctx.fun_decl.meta "Nested borrows are not supported yet"; + cassert + (List.for_all + (fun (_, aproj) -> aproj = V.AIgnoredProjBorrows) + child_projs) + ctx.fun_decl.meta "Nested borrows are not supported yet"; (ctx, None) | AEndedProjBorrows mv -> (* Return the meta-value *) @@ -1960,10 +2002,13 @@ and translate_panic (ctx : bs_ctx) : texpression = (* Create the [Fail] value *) let ret_ty = mk_simpl_tuple_ty [ mk_state_ty; output_ty ] in let ret_v = - mk_result_fail_texpression_with_error_id ctx.fun_decl.meta error_failure_id ret_ty + mk_result_fail_texpression_with_error_id ctx.fun_decl.meta + error_failure_id ret_ty in ret_v - else mk_result_fail_texpression_with_error_id ctx.fun_decl.meta error_failure_id output_ty + else + mk_result_fail_texpression_with_error_id ctx.fun_decl.meta + error_failure_id output_ty in if ctx.inside_loop && Option.is_some ctx.bid then (* We are synthesizing the backward function of a loop body *) @@ -2086,7 +2131,8 @@ and translate_return_with_loop (loop_id : V.LoopId.id) (is_continue : bool) else output in (* Wrap in a result - TODO: check effect_info.can_fail to not always wrap *) - mk_emeta (Tag "return_with_loop") (mk_result_return_texpression ctx.fun_decl.meta output) + mk_emeta (Tag "return_with_loop") + (mk_result_return_texpression ctx.fun_decl.meta output) and translate_function_call (call : S.call) (e : S.expression) (ctx : bs_ctx) : texpression = @@ -2137,8 +2183,8 @@ and translate_function_call (call : S.call) (e : S.expression) (ctx : bs_ctx) : let sg = Option.get call.sg in let decls_ctx = ctx.decls_ctx in let dsg = - translate_fun_sig_with_regions_hierarchy_to_decomposed ctx.fun_decl.meta decls_ctx fid - call.regions_hierarchy sg + translate_fun_sig_with_regions_hierarchy_to_decomposed + ctx.fun_decl.meta decls_ctx fid call.regions_hierarchy sg (List.map (fun _ -> None) sg.inputs) in log#ldebug @@ -2151,8 +2197,8 @@ and translate_function_call (call : S.call) (e : S.expression) (ctx : bs_ctx) : ctx_translate_fwd_generic_args ctx all_generics in let tr_self = - translate_fwd_trait_instance_id ctx.fun_decl.meta ctx.type_ctx.type_infos - tr_self + translate_fwd_trait_instance_id ctx.fun_decl.meta + ctx.type_ctx.type_infos tr_self in (tr_self, all_generics) in @@ -2368,8 +2414,9 @@ and translate_end_abstraction_synth_input (ectx : C.eval_ctx) (abs : V.abs) ^ T.RegionGroupId.to_string rg_id ^ "\n- loop_id: " ^ Print.option_to_string Pure.LoopId.to_string ctx.loop_id - ^ "\n- eval_ctx:\n" ^ eval_ctx_to_string ~meta:(Some ctx.fun_decl.meta) ectx ^ "\n- abs:\n" - ^ abs_to_string ctx abs ^ "\n")); + ^ "\n- eval_ctx:\n" + ^ eval_ctx_to_string ~meta:(Some ctx.fun_decl.meta) ectx + ^ "\n- abs:\n" ^ abs_to_string ctx abs ^ "\n")); (* When we end an input abstraction, this input abstraction gets back the borrows which it introduced in the context through the input @@ -2429,7 +2476,8 @@ and translate_end_abstraction_synth_input (ectx : C.eval_ctx) (abs : V.abs) (* TODO: normalize the types *) if !Config.type_check_pure_code then List.iter - (fun (var, v) -> sanity_check ((var : var).ty = (v : texpression).ty) ctx.fun_decl.meta) + (fun (var, v) -> + sanity_check ((var : var).ty = (v : texpression).ty) ctx.fun_decl.meta) variables_values; (* Translate the next expression *) let next_e = translate_expression e ctx in @@ -2566,7 +2614,8 @@ and translate_end_abstraction_synth_ret (ectx : C.eval_ctx) (abs : V.abs) (* Retrieve the values consumed upon ending the loans inside this * abstraction: as there are no nested borrows, there should be none. *) let consumed = abs_to_consumed ctx ectx abs in - cassert (consumed = []) ctx.fun_decl.meta "Nested borrows are not supported yet"; + cassert (consumed = []) ctx.fun_decl.meta + "Nested borrows are not supported yet"; (* Retrieve the values given back upon ending this abstraction - note that * we don't provide meta-place information, because those assignments will * be inlined anyway... *) @@ -2799,7 +2848,9 @@ and translate_expansion (p : S.mplace option) (sv : V.symbolic_value) let branch = List.hd branches in let ty = branch.branch.ty in (* Sanity check *) - sanity_check (List.for_all (fun br -> br.branch.ty = ty) branches) ctx.fun_decl.meta; + sanity_check + (List.for_all (fun br -> br.branch.ty = ty) branches) + ctx.fun_decl.meta; (* Return *) { e; ty }) | ExpandBool (true_e, false_e) -> @@ -2819,7 +2870,8 @@ and translate_expansion (p : S.mplace option) (sv : V.symbolic_value) ^ pure_ty_to_string ctx true_e.ty ^ "\n\nfalse_e.ty: " ^ pure_ty_to_string ctx false_e.ty)); - save_error ~b:(ty = false_e.ty) (Some ctx.fun_decl.meta) "Internal error, please file an issue"; + save_error ~b:(ty = false_e.ty) (Some ctx.fun_decl.meta) + "Internal error, please file an issue"; { e; ty } | ExpandInt (int_ty, branches, otherwise) -> let translate_branch ((v, branch_e) : V.scalar_value * S.expression) : @@ -2844,8 +2896,9 @@ and translate_expansion (p : S.mplace option) (sv : V.symbolic_value) Match all_branches ) in let ty = otherwise.branch.ty in - sanity_check ( - List.for_all (fun (br : match_branch) -> br.branch.ty = ty) branches) ctx.fun_decl.meta; + sanity_check + (List.for_all (fun (br : match_branch) -> br.branch.ty = ty) branches) + ctx.fun_decl.meta; { e; ty } (* Translate and [ExpandAdt] when there is no branching (i.e., one branch). @@ -2946,7 +2999,9 @@ and translate_ExpandAdt_one_branch (sv : V.symbolic_value) | TAssumed TBox -> (* There should be exactly one variable *) let var = - match vars with [ v ] -> v | _ -> craise ctx.fun_decl.meta "Unreachable" + match vars with + | [ v ] -> v + | _ -> craise ctx.fun_decl.meta "Unreachable" in (* We simply introduce an assignment - the box type is the * identity when extracted ([box a = a]) *) @@ -2997,7 +3052,9 @@ and translate_intro_symbolic (ectx : C.eval_ctx) (p : S.mplace option) | VaCgValue cg_id -> { e = CVar cg_id; ty = var.ty } | VaTraitConstValue (trait_ref, const_name) -> let type_infos = ctx.type_ctx.type_infos in - let trait_ref = translate_fwd_trait_ref ctx.fun_decl.meta type_infos trait_ref in + let trait_ref = + translate_fwd_trait_ref ctx.fun_decl.meta type_infos trait_ref + in let qualif_id = TraitConst (trait_ref, const_name) in let qualif = { id = qualif_id; generics = empty_generic_args } in { e = Qualif qualif; ty = var.ty } @@ -3149,7 +3206,9 @@ and translate_forward_end (ectx : C.eval_ctx) in let state_var = List.map mk_texpression_from_var state_var in - let ret = mk_simpl_tuple_texpression ctx.fun_decl.meta (state_var @ [ ret ]) in + let ret = + mk_simpl_tuple_texpression ctx.fun_decl.meta (state_var @ [ ret ]) + in let ret = mk_result_return_texpression ctx.fun_decl.meta ret in (* Introduce all the let-bindings *) @@ -3377,11 +3436,12 @@ and translate_loop (loop : S.loop) (ctx : bs_ctx) : texpression = in (* Sanity check: all the non-fresh symbolic values are in the context *) - sanity_check ( - List.for_all - (fun (sv : V.symbolic_value) -> - V.SymbolicValueId.Map.mem sv.sv_id ctx.sv_to_var) - loop.input_svalues) ctx.fun_decl.meta; + sanity_check + (List.for_all + (fun (sv : V.symbolic_value) -> + V.SymbolicValueId.Map.mem sv.sv_id ctx.sv_to_var) + loop.input_svalues) + ctx.fun_decl.meta; (* Translate the loop inputs *) let inputs = @@ -3401,7 +3461,9 @@ and translate_loop (loop : S.loop) (ctx : bs_ctx) : texpression = (* The types shouldn't contain borrows - we can translate them as forward types *) List.map (fun ty -> - cassert (not (TypesUtils.ty_has_borrows !ctx.type_ctx.type_infos ty)) !ctx.fun_decl.meta "The types shouldn't contain borrows"; + cassert + (not (TypesUtils.ty_has_borrows !ctx.type_ctx.type_infos ty)) + !ctx.fun_decl.meta "The types shouldn't contain borrows"; ctx_translate_fwd_ty !ctx ty) tys) loop.rg_to_given_back_tys @@ -3589,8 +3651,8 @@ and translate_emeta (meta : S.emeta) (e : S.expression) (ctx : bs_ctx) : | None -> next_e (** Wrap a function body in a match over the fuel to control termination. *) -let wrap_in_match_fuel (meta : Meta.meta) (fuel0 : VarId.id) (fuel : VarId.id) (body : texpression) - : texpression = +let wrap_in_match_fuel (meta : Meta.meta) (fuel0 : VarId.id) (fuel : VarId.id) + (body : texpression) : texpression = let fuel0_var : var = mk_fuel_var fuel0 in let fuel0 = mk_texpression_from_var fuel0_var in let nfuel_var : var = mk_fuel_var fuel in @@ -3736,10 +3798,11 @@ let translate_fun_decl (ctx : bs_ctx) (body : S.expression option) : fun_decl = (List.map (pure_ty_to_string ctx) signature.inputs))); (* TODO: we need to normalize the types *) if !Config.type_check_pure_code then - sanity_check ( - List.for_all - (fun (var, ty) -> (var : var).ty = ty) - (List.combine inputs signature.inputs)) def.meta; + sanity_check + (List.for_all + (fun (var, ty) -> (var : var).ty = ty) + (List.combine inputs signature.inputs)) + def.meta; Some { inputs; inputs_lvs; body } in @@ -3803,10 +3866,13 @@ let translate_trait_decl (ctx : Contexts.decls_ctx) (trait_decl : A.trait_decl) in let generics = translate_generic_params trait_decl.meta llbc_generics in let preds = translate_predicates trait_decl.meta preds in - let parent_clauses = List.map (translate_trait_clause trait_decl.meta) llbc_parent_clauses in + let parent_clauses = + List.map (translate_trait_clause trait_decl.meta) llbc_parent_clauses + in let consts = List.map - (fun (name, (ty, id)) -> (name, (translate_fwd_ty trait_decl.meta type_infos ty, id))) + (fun (name, (ty, id)) -> + (name, (translate_fwd_ty trait_decl.meta type_infos ty, id))) consts in let types = @@ -3854,7 +3920,9 @@ let translate_trait_impl (ctx : Contexts.decls_ctx) (trait_impl : A.trait_impl) in let type_infos = ctx.type_ctx.type_infos in let impl_trait = - translate_trait_decl_ref trait_impl.meta (translate_fwd_ty trait_impl.meta type_infos) llbc_impl_trait + translate_trait_decl_ref trait_impl.meta + (translate_fwd_ty trait_impl.meta type_infos) + llbc_impl_trait in let name = Print.Types.name_to_string @@ -3863,17 +3931,22 @@ let translate_trait_impl (ctx : Contexts.decls_ctx) (trait_impl : A.trait_impl) in let generics = translate_generic_params trait_impl.meta llbc_generics in let preds = translate_predicates trait_impl.meta preds in - let parent_trait_refs = List.map (translate_strait_ref trait_impl.meta) parent_trait_refs in + let parent_trait_refs = + List.map (translate_strait_ref trait_impl.meta) parent_trait_refs + in let consts = List.map - (fun (name, (ty, id)) -> (name, (translate_fwd_ty trait_impl.meta type_infos ty, id))) + (fun (name, (ty, id)) -> + (name, (translate_fwd_ty trait_impl.meta type_infos ty, id))) consts in let types = List.map (fun (name, (trait_refs, ty)) -> ( name, - ( List.map (translate_fwd_trait_ref trait_impl.meta type_infos) trait_refs, + ( List.map + (translate_fwd_trait_ref trait_impl.meta type_infos) + trait_refs, translate_fwd_ty trait_impl.meta type_infos ty ) )) types in diff --git a/compiler/SynthesizeSymbolic.ml b/compiler/SynthesizeSymbolic.ml index bdd27d0f..f7437f7e 100644 --- a/compiler/SynthesizeSymbolic.ml +++ b/compiler/SynthesizeSymbolic.ml @@ -6,22 +6,26 @@ open LlbcAst open SymbolicAst open Errors -let mk_mplace (meta : Meta.meta) (p : place) (ctx : Contexts.eval_ctx) : mplace = +let mk_mplace (meta : Meta.meta) (p : place) (ctx : Contexts.eval_ctx) : mplace + = let bv = Contexts.ctx_lookup_var_binder meta ctx p.var_id in { bv; projection = p.projection } -let mk_opt_mplace (meta : Meta.meta) (p : place option) (ctx : Contexts.eval_ctx) : mplace option = +let mk_opt_mplace (meta : Meta.meta) (p : place option) + (ctx : Contexts.eval_ctx) : mplace option = Option.map (fun p -> mk_mplace meta p ctx) p -let mk_opt_place_from_op (meta : Meta.meta) (op : operand) (ctx : Contexts.eval_ctx) : - mplace option = - match op with Copy p | Move p -> Some (mk_mplace meta p ctx) | Constant _ -> None +let mk_opt_place_from_op (meta : Meta.meta) (op : operand) + (ctx : Contexts.eval_ctx) : mplace option = + match op with + | Copy p | Move p -> Some (mk_mplace meta p ctx) + | Constant _ -> None let mk_emeta (m : emeta) (e : expression) : expression = Meta (m, e) -let synthesize_symbolic_expansion (meta : Meta.meta) (sv : symbolic_value) (place : mplace option) - (seel : symbolic_expansion option list) (el : expression list option) : - expression option = +let synthesize_symbolic_expansion (meta : Meta.meta) (sv : symbolic_value) + (place : mplace option) (seel : symbolic_expansion option list) + (el : expression list option) : expression option = match el with | None -> None | Some el -> @@ -87,9 +91,9 @@ let synthesize_symbolic_expansion (meta : Meta.meta) (sv : symbolic_value) (plac in Some (Expansion (place, sv, expansion)) -let synthesize_symbolic_expansion_no_branching (meta : Meta.meta) (sv : symbolic_value) - (place : mplace option) (see : symbolic_expansion) (e : expression option) : - expression option = +let synthesize_symbolic_expansion_no_branching (meta : Meta.meta) + (sv : symbolic_value) (place : mplace option) (see : symbolic_expansion) + (e : expression option) : expression option = let el = Option.map (fun e -> [ e ]) e in synthesize_symbolic_expansion meta sv place [ Some see ] el diff --git a/compiler/ValuesUtils.ml b/compiler/ValuesUtils.ml index 9c4b8b45..d2c48d13 100644 --- a/compiler/ValuesUtils.ml +++ b/compiler/ValuesUtils.ml @@ -15,7 +15,8 @@ let mk_typed_value (meta : Meta.meta) (ty : ty) (value : value) : typed_value = sanity_check (ty_is_ety ty) meta; { value; ty } -let mk_typed_avalue (meta : Meta.meta) (ty : ty) (value : avalue) : typed_avalue = +let mk_typed_avalue (meta : Meta.meta) (ty : ty) (value : avalue) : typed_avalue + = sanity_check (ty_is_rty ty) meta; { value; ty } @@ -51,7 +52,8 @@ let is_symbolic (v : value) : bool = let as_symbolic (meta : Meta.meta) (v : value) : symbolic_value = match v with VSymbolic s -> s | _ -> craise meta "Unexpected" -let as_mut_borrow (meta : Meta.meta) (v : typed_value) : BorrowId.id * typed_value = +let as_mut_borrow (meta : Meta.meta) (v : typed_value) : + BorrowId.id * typed_value = match v.value with | VBorrow (VMutBorrow (bid, bv)) -> (bid, bv) | _ -> craise meta "Unexpected" |