From 6f22190cba92a44b6c74bfcce8f5ed142a68e195 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Thu, 31 Aug 2023 12:47:43 +0200 Subject: Start adding support for traits --- compiler/SynthesizeSymbolic.ml | 34 +++++++++++++++++----------------- 1 file changed, 17 insertions(+), 17 deletions(-) (limited to 'compiler/SynthesizeSymbolic.ml') diff --git a/compiler/SynthesizeSymbolic.ml b/compiler/SynthesizeSymbolic.ml index 857fea97..cac56487 100644 --- a/compiler/SynthesizeSymbolic.ml +++ b/compiler/SynthesizeSymbolic.ml @@ -64,7 +64,7 @@ let synthesize_symbolic_expansion (sv : V.symbolic_value) assert (otherwise_see = None); (* Return *) ExpandInt (int_ty, branches, otherwise) - | T.Adt (_, _, _, _) -> + | T.Adt (_, _) -> (* Branching: it is necessarily an enumeration expansion *) let get_variant (see : V.symbolic_expansion option) : T.VariantId.id option * V.symbolic_value list = @@ -85,7 +85,7 @@ let synthesize_symbolic_expansion (sv : V.symbolic_value) match ls with | [ (Some see, exp) ] -> ExpandNoBranch (see, exp) | _ -> raise (Failure "Ill-formed borrow expansion")) - | T.TypeVar _ | T.Literal Char | Never -> + | T.TypeVar _ | T.Literal Char | Never | T.TraitType _ -> raise (Failure "Ill-formed symbolic expansion") in Some (Expansion (place, sv, expansion)) @@ -97,10 +97,10 @@ let synthesize_symbolic_expansion_no_branching (sv : V.symbolic_value) synthesize_symbolic_expansion sv place [ Some see ] el let synthesize_function_call (call_id : call_id) (ctx : Contexts.eval_ctx) - (abstractions : V.AbstractionId.id list) (type_params : T.ety list) - (const_generic_params : T.const_generic list) (args : V.typed_value list) - (args_places : mplace option list) (dest : V.symbolic_value) - (dest_place : mplace option) (e : expression option) : expression option = + (abstractions : V.AbstractionId.id list) (generics : T.egeneric_args) + (args : V.typed_value list) (args_places : mplace option list) + (dest : V.symbolic_value) (dest_place : mplace option) + (e : expression option) : expression option = Option.map (fun e -> let call = @@ -108,8 +108,7 @@ let synthesize_function_call (call_id : call_id) (ctx : Contexts.eval_ctx) call_id; ctx; abstractions; - type_params; - const_generic_params; + generics; args; dest; args_places; @@ -125,26 +124,27 @@ let synthesize_global_eval (gid : A.GlobalDeclId.id) (dest : V.symbolic_value) let synthesize_regular_function_call (fun_id : A.fun_id) (call_id : V.FunCallId.id) (ctx : Contexts.eval_ctx) - (abstractions : V.AbstractionId.id list) (type_params : T.ety list) - (const_generic_params : T.const_generic list) (args : V.typed_value list) - (args_places : mplace option list) (dest : V.symbolic_value) - (dest_place : mplace option) (e : expression option) : expression option = + (abstractions : V.AbstractionId.id list) (generics : T.egeneric_args) + (args : V.typed_value list) (args_places : mplace option list) + (dest : V.symbolic_value) (dest_place : mplace option) + (e : expression option) : expression option = synthesize_function_call (Fun (fun_id, call_id)) - ctx abstractions type_params const_generic_params args args_places dest - dest_place e + ctx abstractions generics args args_places dest dest_place e let synthesize_unary_op (ctx : Contexts.eval_ctx) (unop : E.unop) (arg : V.typed_value) (arg_place : mplace option) (dest : V.symbolic_value) (dest_place : mplace option) (e : expression option) : expression option = - synthesize_function_call (Unop unop) ctx [] [] [] [ arg ] [ arg_place ] dest - dest_place e + let generics = TypesUtils.mk_empty_generic_args in + synthesize_function_call (Unop unop) ctx [] generics [ arg ] [ arg_place ] + dest dest_place e let synthesize_binary_op (ctx : Contexts.eval_ctx) (binop : E.binop) (arg0 : V.typed_value) (arg0_place : mplace option) (arg1 : V.typed_value) (arg1_place : mplace option) (dest : V.symbolic_value) (dest_place : mplace option) (e : expression option) : expression option = - synthesize_function_call (Binop binop) ctx [] [] [] [ arg0; arg1 ] + let generics = TypesUtils.mk_empty_generic_args in + synthesize_function_call (Binop binop) ctx [] generics [ arg0; arg1 ] [ arg0_place; arg1_place ] dest dest_place e let synthesize_end_abstraction (ctx : Contexts.eval_ctx) (abs : V.abs) -- cgit v1.3.1 From 5921be8e2e8955db5101354d8bf29ae6a3693f48 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Mon, 11 Sep 2023 06:35:07 +0200 Subject: Make progress on correctly handling trait method calls in the symbolic execution --- compiler/Extract.ml | 4 +- compiler/ExtractBase.ml | 16 +++-- compiler/InterpreterStatements.ml | 126 ++++++++++++++++++++++++++++++-------- compiler/InterpreterUtils.ml | 3 + compiler/Print.ml | 8 +++ compiler/PrintPure.ml | 7 ++- compiler/Pure.ml | 14 ++++- compiler/PureMicroPasses.ml | 29 ++++----- compiler/ReorderDecls.ml | 4 +- compiler/SymbolicAst.ml | 2 +- compiler/SymbolicToPure.ml | 73 ++++++++++++++++++---- compiler/SynthesizeSymbolic.ml | 2 +- 12 files changed, 221 insertions(+), 67 deletions(-) (limited to 'compiler/SynthesizeSymbolic.ml') diff --git a/compiler/Extract.ml b/compiler/Extract.ml index d000c447..fe007d31 100644 --- a/compiler/Extract.ml +++ b/compiler/Extract.ml @@ -3411,7 +3411,7 @@ let extract_fun_comment (ctx : extraction_ctx) (fmt : F.formatter) (def : fun_decl) : unit = let { keep_fwd; num_backs } = PureUtils.RegularFunIdMap.find - (A.Regular def.def_id, def.loop_id, def.back_id) + (Pure.FunId (A.Regular def.def_id), def.loop_id, def.back_id) ctx.fun_name_info in let comment_pre = "[" ^ Print.fun_name_to_string def.basename ^ "]: " in @@ -3908,7 +3908,7 @@ let extract_global_decl (ctx : extraction_ctx) (fmt : F.formatter) let decl_name = ctx_get_global with_opaque_pre global.def_id ctx in let body_name = ctx_get_function with_opaque_pre - (FromLlbc (Regular global.body_id, None, None)) + (FromLlbc (Pure.FunId (Regular global.body_id), None, None)) ctx in diff --git a/compiler/ExtractBase.ml b/compiler/ExtractBase.ml index 9c9e08a5..438a3475 100644 --- a/compiler/ExtractBase.ml +++ b/compiler/ExtractBase.ml @@ -703,10 +703,13 @@ let id_to_string (id : id) (ctx : extraction_ctx) : string = | FromLlbc (fid, lp_id, rg_id) -> let fun_name = match fid with - | Regular fid -> + | FunId (Regular fid) -> Print.fun_name_to_string (A.FunDeclId.Map.find fid fun_decls).name - | Assumed aid -> A.show_assumed_fun_id aid + | FunId (Assumed aid) -> A.show_assumed_fun_id aid + | TraitMethod _ -> + (* Shouldn't happen *) + raise (Failure "Unexpected") in let lp_kind = @@ -908,7 +911,7 @@ let ctx_get_function (with_opaque_pre : bool) (id : fun_id) let ctx_get_local_function (with_opaque_pre : bool) (id : A.FunDeclId.id) (lp : LoopId.id option) (rg : RegionGroupId.id option) (ctx : extraction_ctx) : string = - ctx_get_function with_opaque_pre (FromLlbc (Regular id, lp, rg)) ctx + ctx_get_function with_opaque_pre (FromLlbc (FunId (Regular id), lp, rg)) ctx let ctx_get_type (with_opaque_pre : bool) (id : type_id) (ctx : extraction_ctx) : string = @@ -1212,7 +1215,7 @@ let ctx_add_global_decl_and_body (def : A.global_decl) (ctx : extraction_ctx) : | None -> (* Not the case: "standard" registration *) let name = ctx.fmt.global_name def.name in - let body = FunId (FromLlbc (Regular def.body_id, None, None)) in + let body = FunId (FromLlbc (FunId (Regular def.body_id), None, None)) in let ctx = ctx_add is_opaque decl (name ^ "_c") ctx in let ctx = ctx_add is_opaque body (name ^ "_body") ctx in ctx @@ -1256,7 +1259,7 @@ let ctx_add_fun_decl (trans_group : pure_fun_translation) (def : fun_decl) let is_opaque = def.body = None in (* Add the function name *) let def_name = ctx_compute_fun_name trans_group def ctx in - let fun_id = (A.Regular def_id, def.loop_id, def.back_id) in + let fun_id = (Pure.FunId (Regular def_id), def.loop_id, def.back_id) in let ctx = ctx_add is_opaque (FunId (FromLlbc fun_id)) def_name ctx in (* Add the name info *) { @@ -1381,7 +1384,8 @@ let initialize_names_map (fmt : formatter) (init : names_map_init) : names_map = in let assumed_functions = List.map - (fun (fid, rg, name) -> (FromLlbc (A.Assumed fid, None, rg), name)) + (fun (fid, rg, name) -> + (FromLlbc (Pure.FunId (A.Assumed fid), None, rg), name)) init.assumed_llbc_functions @ List.map (fun (fid, name) -> (Pure fid, name)) init.assumed_pure_functions in diff --git a/compiler/InterpreterStatements.ml b/compiler/InterpreterStatements.ml index 5791a359..1ea16e58 100644 --- a/compiler/InterpreterStatements.ml +++ b/compiler/InterpreterStatements.ml @@ -1082,12 +1082,12 @@ and eval_function_call_concrete (config : C.config) (call : A.call) : st_cm_fun * where we haven't panicked. Of course, the translation needs to take the * panic case into account... *) eval_assumed_function_call_concrete config fid call (cf Unit) ctx - | A.TraitMethod (_, _) -> raise (Failure "Unimplemented") + | A.TraitMethod _ -> raise (Failure "Unimplemented") and eval_function_call_symbolic (config : C.config) (call : A.call) : st_cm_fun = match call.func with - | A.FunId (A.Regular _) | A.TraitMethod (_, _) -> + | A.FunId (A.Regular _) | A.TraitMethod _ -> eval_transparent_function_call_symbolic config call | A.FunId (A.Assumed fid) -> eval_assumed_function_call_symbolic config fid call @@ -1182,7 +1182,7 @@ and eval_transparent_function_call_symbolic (config : C.config) (call : A.call) : st_cm_fun = fun cf ctx -> (* Instantiate the signature and introduce fresh abstractions and region ids while doing so *) - let def, inst_sg = + let func, def, self_trait_ref, inst_sg = match call.func with | A.FunId (A.Regular fid) -> let def = C.ctx_lookup_fun_decl ctx fid in @@ -1190,11 +1190,19 @@ and eval_transparent_function_call_symbolic (config : C.config) (call : A.call) let inst_sg = instantiate_fun_sig ctx call.generics tr_self def.A.signature in - (def, inst_sg) + (call.func, def, None, inst_sg) | A.FunId (A.Assumed _) -> (* Unreachable: must be a transparent function *) raise (Failure "Unreachable") - | A.TraitMethod (trait_ref, method_name) -> ( + | A.TraitMethod (trait_ref, method_name, _) -> ( + log#ldebug + (lazy + ("trait method call:\n- call: " ^ call_to_string ctx call + ^ "\n- method name: " ^ method_name ^ "\n- generics:\n" + ^ egeneric_args_to_string ctx call.generics + ^ "\n- trait and method generics:\n" + ^ egeneric_args_to_string ctx + (Option.get call.trait_and_method_generic_args))); (* When instantiating, we need to group the generics for the trait ref and the method *) let generics = Option.get call.trait_and_method_generic_args in @@ -1202,31 +1210,97 @@ and eval_transparent_function_call_symbolic (config : C.config) (call : A.call) depending on whethere we call a top-level trait method impl or the method from a local clause *) match trait_ref.trait_id with - | TraitImpl impl_id -> + | TraitImpl impl_id -> ( (* Lookup the trait impl *) let trait_impl = C.ctx_lookup_trait_impl ctx impl_id in - let _, method_id = - List.find + log#ldebug + (lazy ("trait impl: " ^ trait_impl_to_string ctx trait_impl)); + (* First look in the required methods *) + let method_id = + List.find_opt (fun (s, _) -> s = method_name) trait_impl.required_methods in - let method_def = C.ctx_lookup_fun_decl ctx method_id in - (* Instantiate *) - let tr_self = T.UnknownTrait __FUNCTION__ in - let inst_sg = - instantiate_fun_sig ctx generics tr_self method_def.A.signature - in - (method_def, inst_sg) + match method_id with + | Some (_, id) -> + let method_def = C.ctx_lookup_fun_decl ctx id in + (* Instantiate *) + let tr_self = + T.TraitRef (etrait_ref_no_regions_to_gr_trait_ref trait_ref) + in + let inst_sg = + instantiate_fun_sig ctx generics tr_self + method_def.A.signature + in + (call.func, method_def, None, inst_sg) + | None -> + (* If not found, lookup the methods provided by the trait *declaration* + (remember: for now, we forbid overriding provided methods) *) + assert (trait_impl.provided_methods = []); + let trait_decl = + C.ctx_lookup_trait_decl ctx + trait_ref.trait_decl_ref.trait_decl_id + in + let _, method_id = + List.find + (fun (s, _) -> s = method_name) + trait_decl.provided_methods + in + let method_id = Option.get method_id in + let method_def = C.ctx_lookup_fun_decl ctx method_id in + (* For the instantiation we have to do something perculiar + because the method was defined for the trait declaration. + We have to group: + - the parameters given to the trait decl reference + - the parameters given to the method itself + For instance: + {[ + trait Foo { + fn f(...) { ... } + } + + fn g(x : G) where Clause0: Foo + { + x.f::(...) // The arguments to f are: + } + ]} + *) + let generics = + TypesUtils.merge_generic_args + trait_ref.trait_decl_ref.decl_generics call.generics + in + log#ldebug + (lazy + ("provided method call:" ^ "\n- method name: " ^ method_name + ^ "\n- generics:\n" + ^ egeneric_args_to_string ctx generics)); + let tr_self = + T.TraitRef (etrait_ref_no_regions_to_gr_trait_ref trait_ref) + in + let inst_sg = + instantiate_fun_sig ctx generics tr_self + method_def.A.signature + in + (* We directly call the function, pretending it is not a trait method call *) + (* TODO: we need to add the self trait ref *) + let func = A.FunId (A.Regular method_def.def_id) in + (func, method_def, Some trait_ref, inst_sg)) | _ -> (* We are using a local clause - we lookup the trait decl *) let trait_decl = C.ctx_lookup_trait_decl ctx trait_ref.trait_decl_ref.trait_decl_id in - (* Lookup the method decl *) + (* Lookup the method decl in the required *and* the provided methods *) let _, method_id = + let provided = + List.filter_map + (fun (id, f) -> + match f with None -> None | Some f -> Some (id, f)) + trait_decl.provided_methods + in List.find (fun (s, _) -> s = method_name) - trait_decl.required_methods + (List.append trait_decl.required_methods provided) in let method_def = C.ctx_lookup_fun_decl ctx method_id in (* Instantiate *) @@ -1238,26 +1312,30 @@ and eval_transparent_function_call_symbolic (config : C.config) (call : A.call) let inst_sg = instantiate_fun_sig ctx generics tr_self method_def.A.signature in - (method_def, inst_sg)) + (call.func, method_def, None, inst_sg)) in (* Sanity check *) assert (List.length call.args = List.length def.A.signature.inputs); (* Evaluate the function call *) - eval_function_call_symbolic_from_inst_sig config call.func inst_sg + eval_function_call_symbolic_from_inst_sig config func inst_sg self_trait_ref call.generics call.args call.dest cf ctx (** Evaluate a function call in symbolic mode by using the function signature. This allows us to factorize the evaluation of local and non-local function calls in symbolic mode: only their signatures matter. + + The [self_trait_ref] trait ref refers to [Self]. We use it when calling + a provided trait method, because those methods have a special treatment: + we dot not group them with the required trait methods, and forbid (for now) + overriding them. We treat them as regular method, which take an additional + trait ref as input. *) and eval_function_call_symbolic_from_inst_sig (config : C.config) (fid : A.fun_id_or_trait_method_ref) (inst_sg : A.inst_fun_sig) - (generics : T.egeneric_args) (args : E.operand list) (dest : E.place) : - st_cm_fun = + (self_trait_ref : T.etrait_ref option) (generics : T.egeneric_args) + (args : E.operand list) (dest : E.place) : st_cm_fun = fun cf ctx -> - (* TODO: trait methods are not supported yet *) - let fid = match fid with A.FunId fid -> fid | _ -> raise (Failure "TODO") in (* Generate a fresh symbolic value for the return value *) let ret_sv_ty = inst_sg.A.output in let ret_spc = mk_fresh_symbolic_value V.FunCallRet ret_sv_ty in @@ -1427,7 +1505,7 @@ and eval_assumed_function_call_symbolic (config : C.config) (* Evaluate the function call *) eval_function_call_symbolic_from_inst_sig config (A.FunId (A.Assumed fid)) - inst_sig generics args dest cf ctx + inst_sig None generics args dest cf ctx (** Evaluate a statement seen as a function body *) and eval_function_body (config : C.config) (body : A.statement) : st_cm_fun = diff --git a/compiler/InterpreterUtils.ml b/compiler/InterpreterUtils.ml index 0986c53b..8a7e8c52 100644 --- a/compiler/InterpreterUtils.ml +++ b/compiler/InterpreterUtils.ml @@ -38,6 +38,9 @@ let typed_value_to_string = PA.typed_value_to_string let typed_avalue_to_string = PA.typed_avalue_to_string let place_to_string = PA.place_to_string let operand_to_string = PA.operand_to_string +let egeneric_args_to_string = PA.egeneric_args_to_string +let call_to_string = PA.call_to_string +let trait_impl_to_string = PA.trait_impl_to_string let statement_to_string ctx = PA.statement_to_string ctx "" " " let statement_to_string_with_tab ctx = PA.statement_to_string ctx " " " " let env_elem_to_string ctx = PA.env_elem_to_string ctx "" " " diff --git a/compiler/Print.ml b/compiler/Print.ml index aebfd09c..55aa0c53 100644 --- a/compiler/Print.ml +++ b/compiler/Print.ml @@ -698,11 +698,19 @@ module EvalCtxLlbcAst = struct let fmt = PC.eval_ctx_to_ast_formatter ctx in PE.operand_to_string fmt op + let call_to_string (ctx : C.eval_ctx) (call : A.call) : string = + let fmt = PC.eval_ctx_to_ast_formatter ctx in + PA.call_to_string fmt "" call + let statement_to_string (ctx : C.eval_ctx) (indent : string) (indent_incr : string) (e : A.statement) : string = let fmt = PC.eval_ctx_to_ast_formatter ctx in PA.statement_to_string fmt indent indent_incr e + let trait_impl_to_string (ctx : C.eval_ctx) (timpl : A.trait_impl) : string = + let fmt = PC.eval_ctx_to_ast_formatter ctx in + PA.trait_impl_to_string fmt " " " " timpl + let env_elem_to_string (ctx : C.eval_ctx) (indent : string) (indent_incr : string) (ev : C.env_elem) : string = let fmt = PC.eval_ctx_to_ctx_formatter ctx in diff --git a/compiler/PrintPure.ml b/compiler/PrintPure.ml index c7f59ec9..d539dcf6 100644 --- a/compiler/PrintPure.ml +++ b/compiler/PrintPure.ml @@ -629,8 +629,11 @@ let regular_fun_id_to_string (fmt : ast_formatter) (fun_id : fun_id) : string = | FromLlbc (fid, lp_id, rg_id) -> let f = match fid with - | Regular fid -> fmt.fun_decl_id_to_string fid - | Assumed fid -> llbc_assumed_fun_id_to_string fid + | FunId (Regular fid) -> fmt.fun_decl_id_to_string fid + | FunId (Assumed fid) -> llbc_assumed_fun_id_to_string fid + | TraitMethod (trait_ref, method_name, _) -> + let fmt = ast_to_type_formatter fmt in + trait_ref_to_string fmt true trait_ref ^ "." ^ method_name in f ^ fun_suffix lp_id rg_id | Pure fid -> pure_assumed_fun_id_to_string fid diff --git a/compiler/Pure.ml b/compiler/Pure.ml index 81060c43..47c7beb4 100644 --- a/compiler/Pure.ml +++ b/compiler/Pure.ml @@ -306,6 +306,7 @@ and trait_instance_id = | UnknownTrait of string [@@deriving show, + ord, visitors { name = "iter_ty"; @@ -369,7 +370,7 @@ type trait_type_constraint = { type_name : trait_item_name; ty : ty; } -[@@deriving show] +[@@deriving show, ord] type predicates = { trait_type_constraints : trait_type_constraint list } [@@deriving show] @@ -530,8 +531,15 @@ type pure_assumed_fun_id = | FuelEqZero (** Test if some fuel is equal to 0 - TODO: ugly *) [@@deriving show, ord] +type fun_id_or_trait_method_ref = + | FunId of A.fun_id + | TraitMethod of trait_ref * string * fun_decl_id + (** The fun decl id is not really needed and here for convenience purposes *) +[@@deriving show, ord] + (** A function id for a non-assumed function *) -type regular_fun_id = A.fun_id * LoopId.id option * T.RegionGroupId.id option +type regular_fun_id = + fun_id_or_trait_method_ref * LoopId.id option * T.RegionGroupId.id option [@@deriving show, ord] (** A function identifier *) @@ -1003,7 +1011,7 @@ type trait_decl = { consts : (trait_item_name * (ty * global_decl_id option)) list; types : (trait_item_name * (trait_clause list * ty option)) list; required_methods : (trait_item_name * fun_decl_id) list; - provided_methods : trait_item_name list; + provided_methods : (trait_item_name * fun_decl_id option) list; } [@@deriving show] diff --git a/compiler/PureMicroPasses.ml b/compiler/PureMicroPasses.ml index 6c9c3a91..53148dbb 100644 --- a/compiler/PureMicroPasses.ml +++ b/compiler/PureMicroPasses.ml @@ -765,7 +765,7 @@ let inline_useless_var_reassignments (inline_named : bool) (inline_pure : bool) In this situation, we can remove the call [f@fwd x]. *) let expression_contains_child_call_in_all_paths (ctx : trans_ctx) - (id0 : A.fun_id) (lp_id0 : LoopId.id option) + (id0 : fun_id_or_trait_method_ref) (lp_id0 : LoopId.id option) (rg_id0 : T.RegionGroupId.id option) (generics0 : generic_args) (args0 : texpression list) (e : texpression) : bool = let check_call (fun_id1 : fun_or_op_id) (generics1 : generic_args) @@ -791,6 +791,11 @@ let expression_contains_child_call_in_all_paths (ctx : trans_ctx) (* We need to use the regions hierarchy *) (* First, lookup the signature of the LLBC function *) let sg = + let id0 = + match id0 with + | FunId fun_id -> fun_id + | TraitMethod (_, _, fun_decl_id) -> A.Regular fun_decl_id + in LlbcAstUtils.lookup_fun_sig id0 ctx.fun_context.fun_decls in (* Compute the set of ancestors of the function in call1 *) @@ -1521,7 +1526,7 @@ let eliminate_box_functions (_ctx : trans_ctx) (def : fun_decl) : fun_decl = match opt_destruct_function_call e with | Some (fun_id, _tys, args) -> ( match fun_id with - | Fun (FromLlbc (A.Assumed aid, _lp_id, rg_id)) -> ( + | Fun (FromLlbc (FunId (A.Assumed aid), _lp_id, rg_id)) -> ( (* Below, when dealing with the arguments: we consider the very * general case, where functions could be boxed (meaning we * could have: [box_new f x]) @@ -2024,7 +2029,6 @@ let filter_loop_inputs (transl : pure_fun_translation list) : additional parameters. *) let used_map = ref FunLoopIdMap.empty in - let fun_id_to_fun_loop_id (fid, loop_id, _) = (fid, loop_id) in (* We start by computing the filtering information, for each function *) let compute_one_filter_info (decl : fun_decl) = @@ -2069,8 +2073,8 @@ let filter_loop_inputs (transl : pure_fun_translation list) : match e_app.e with | Qualif qualif -> ( match qualif.id with - | FunOrOp (Fun (FromLlbc fun_id')) -> - if fun_id_to_fun_loop_id fun_id' = fun_id then ( + | FunOrOp (Fun (FromLlbc (FunId fun_id', loop_id', _))) -> + if (fun_id', loop_id') = fun_id then ( (* For each argument, check if it is exactly the original input parameter. Note that there shouldn't be partial applications of loop functions: the number of arguments @@ -2129,9 +2133,9 @@ let filter_loop_inputs (transl : pure_fun_translation list) : (* We then apply the filtering to all the function definitions at once *) let filter_in_one (decl : fun_decl) : fun_decl = (* Filter the function signature *) - let fun_id = (A.Regular decl.def_id, decl.loop_id, decl.back_id) in + let fun_id = (A.Regular decl.def_id, decl.loop_id) in let decl = - match FunLoopIdMap.find_opt (fun_id_to_fun_loop_id fun_id) !used_map with + match FunLoopIdMap.find_opt fun_id !used_map with | None -> (* Nothing to filter *) decl | Some used_info -> let num_filtered = @@ -2179,9 +2183,7 @@ let filter_loop_inputs (transl : pure_fun_translation list) : let { inputs; inputs_lvs; body } = body in let inputs, inputs_lvs = - match - FunLoopIdMap.find_opt (fun_id_to_fun_loop_id fun_id) !used_map - with + match FunLoopIdMap.find_opt fun_id !used_map with | None -> (* Nothing to filter *) (inputs, inputs_lvs) | Some used_info -> let inputs = filter_prefix used_info inputs in @@ -2201,11 +2203,10 @@ let filter_loop_inputs (transl : pure_fun_translation list) : match e_app.e with | Qualif qualif -> ( match qualif.id with - | FunOrOp (Fun (FromLlbc fun_id)) -> ( + | FunOrOp (Fun (FromLlbc (FunId fun_id, loop_id, _))) + -> ( match - FunLoopIdMap.find_opt - (fun_id_to_fun_loop_id fun_id) - !used_map + FunLoopIdMap.find_opt (fun_id, loop_id) !used_map with | None -> super#visit_texpression env e | Some used_info -> diff --git a/compiler/ReorderDecls.ml b/compiler/ReorderDecls.ml index db646a87..10b68da3 100644 --- a/compiler/ReorderDecls.ml +++ b/compiler/ReorderDecls.ml @@ -46,8 +46,8 @@ let compute_body_fun_deps (e : texpression) : FunIdSet.t = | Pure _ -> () | FromLlbc (fid, lp_id, rg_id) -> ( match fid with - | Assumed _ -> () - | Regular fid -> + | FunId (Assumed _) -> () + | TraitMethod (_, _, fid) | FunId (Regular fid) -> let id = { def_id = fid; lp_id; rg_id } in ids := FunIdSet.add id !ids)) end diff --git a/compiler/SymbolicAst.ml b/compiler/SymbolicAst.ml index b170ebe5..4df8fec7 100644 --- a/compiler/SymbolicAst.ml +++ b/compiler/SymbolicAst.ml @@ -29,7 +29,7 @@ type mplace = { [@@deriving show] type call_id = - | Fun of A.fun_id * V.FunCallId.id + | Fun of A.fun_id_or_trait_method_ref * V.FunCallId.id (** A "regular" function (i.e., a function which is not a primitive operation) *) | Unop of E.unop | Binop of E.binop diff --git a/compiler/SymbolicToPure.ml b/compiler/SymbolicToPure.ml index 3312e22d..1da0521d 100644 --- a/compiler/SymbolicToPure.ml +++ b/compiler/SymbolicToPure.ml @@ -727,6 +727,54 @@ let type_check_texpression (ctx : bs_ctx) (e : texpression) : unit = let ctx = mk_type_check_ctx ctx in PureTypeCheck.check_texpression ctx e +let translate_fun_id_or_trait_method_ref (ctx : bs_ctx) + (id : A.fun_id_or_trait_method_ref) : fun_id_or_trait_method_ref = + match id with + | A.FunId fun_id -> FunId fun_id + | TraitMethod (trait_ref, method_name, fun_decl_id) -> + let type_infos = ctx.type_context.type_infos in + let trait_ref = translate_fwd_trait_ref 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) + (args : texpression list) (ctx : bs_ctx) : bs_ctx = + let calls = ctx.calls in + assert (not (V.FunCallId.Map.mem call_id calls)); + let info = + { forward; forward_inputs = args; backwards = T.RegionGroupId.Map.empty } + in + let calls = V.FunCallId.Map.add call_id info calls in + { ctx with calls } + +(** [back_args]: the *additional* list of inputs received by the backward function *) +let bs_ctx_register_backward_call (abs : V.abs) (call_id : V.FunCallId.id) + (back_id : T.RegionGroupId.id) (back_args : texpression list) (ctx : bs_ctx) + : bs_ctx * fun_or_op_id = + (* Insert the abstraction in the call informations *) + let info = V.FunCallId.Map.find call_id ctx.calls in + assert (not (T.RegionGroupId.Map.mem back_id info.backwards)); + let backwards = + T.RegionGroupId.Map.add back_id (abs, back_args) info.backwards + in + let info = { info with backwards } in + let calls = V.FunCallId.Map.add call_id info ctx.calls in + (* Insert the abstraction in the abstractions map *) + let abstractions = ctx.abstractions in + assert (not (V.AbstractionId.Map.mem abs.abs_id abstractions)); + let abstractions = + V.AbstractionId.Map.add abs.abs_id (abs, back_args) abstractions + in + (* Retrieve the fun_id *) + let fun_id = + match info.forward.call_id with + | S.Fun (fid, _) -> + let fid = translate_fun_id_or_trait_method_ref ctx fid in + Fun (FromLlbc (fid, None, Some back_id)) + | S.Unop _ | S.Binop _ -> raise (Failure "Unreachable") + in + (* Update the context and return *) + ({ ctx with calls; abstractions }, fun_id) + (** List the ancestors of an abstraction *) let list_ancestor_abstractions_ids (ctx : bs_ctx) (abs : V.abs) (call_id : V.FunCallId.id) : V.AbstractionId.id list = @@ -780,10 +828,10 @@ let mk_fuel_input_as_list (ctx : bs_ctx) (info : fun_effect_info) : (** Small utility. *) let get_fun_effect_info (fun_infos : FA.fun_info A.FunDeclId.Map.t) - (fun_id : A.fun_id) (lid : V.LoopId.id option) + (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 - | A.Regular fid -> + | A.TraitMethod (_, _, fid) | A.FunId (A.Regular fid) -> let info = A.FunDeclId.Map.find fid fun_infos in let stateful_group = info.stateful in let stateful = @@ -796,7 +844,7 @@ let get_fun_effect_info (fun_infos : FA.fun_info A.FunDeclId.Map.t) can_diverge = info.can_diverge; is_rec = info.is_rec || Option.is_some lid; } - | A.Assumed aid -> + | A.FunId (A.Assumed aid) -> assert (lid = None); { can_fail = Assumed.assumed_can_fail aid; @@ -828,7 +876,7 @@ let translate_fun_sig (fun_infos : FA.fun_info A.FunDeclId.Map.t) in (* Is the function stateful, and can it fail? *) let lid = None in - let effect_info = get_fun_effect_info fun_infos fun_id lid bid in + let effect_info = get_fun_effect_info fun_infos (A.FunId fun_id) lid bid in (* List the inputs for: * - the fuel * - the forward function @@ -1615,7 +1663,8 @@ and translate_function_call (call : S.call) (e : S.expression) (ctx : bs_ctx) : match call.call_id with | S.Fun (fid, call_id) -> (* Regular function call *) - let func = Fun (FromLlbc (fid, None, None)) in + let fid_t = translate_fun_id_or_trait_method_ref ctx fid in + let func = Fun (FromLlbc (fid_t, None, None)) in (* Retrieve the effect information about this function (can fail, * takes a state as input, etc.) *) let effect_info = @@ -2043,8 +2092,8 @@ and translate_end_abstraction_loop (ectx : C.eval_ctx) (abs : V.abs) | V.LoopCall -> let fun_id = A.Regular ctx.fun_decl.A.def_id in let effect_info = - get_fun_effect_info ctx.fun_context.fun_infos fun_id (Some vloop_id) - (Some rg_id) + get_fun_effect_info ctx.fun_context.fun_infos (A.FunId fun_id) + (Some vloop_id) (Some rg_id) in let loop_info = LoopId.Map.find loop_id ctx.loops in let generics = loop_info.generics in @@ -2095,7 +2144,7 @@ and translate_end_abstraction_loop (ectx : C.eval_ctx) (abs : V.abs) if effect_info.can_fail then mk_result_ty output.ty else output.ty in let func_ty = mk_arrows input_tys ret_ty in - let func = Fun (FromLlbc (fun_id, Some loop_id, Some rg_id)) in + let func = Fun (FromLlbc (FunId fun_id, Some loop_id, Some rg_id)) in let func = { id = FunOrOp func; generics } in let func = { e = Qualif func; ty = func_ty } in let call = mk_apps func args in @@ -2508,7 +2557,7 @@ and translate_forward_end (ectx : C.eval_ctx) (* Lookup the effect info for the loop function *) let fid = A.Regular ctx.fun_decl.A.def_id in let effect_info = - get_fun_effect_info ctx.fun_context.fun_infos fid None ctx.bid + get_fun_effect_info ctx.fun_context.fun_infos (A.FunId fid) None ctx.bid in (* Introduce a fresh output value for the forward function *) @@ -2553,7 +2602,7 @@ and translate_forward_end (ectx : C.eval_ctx) let out_pat = mk_simpl_tuple_pattern out_pats in let loop_call = - let fun_id = Fun (FromLlbc (fid, Some loop_id, None)) in + let fun_id = Fun (FromLlbc (FunId fid, Some loop_id, None)) in let func = { id = FunOrOp fun_id; generics = loop_info.generics } in let input_tys = (List.map (fun (x : texpression) -> x.ty)) args in let ret_ty = @@ -2873,8 +2922,8 @@ let translate_fun_decl (ctx : bs_ctx) (body : S.expression option) : fun_decl = | None -> None | Some body -> let effect_info = - get_fun_effect_info ctx.fun_context.fun_infos (Regular def_id) None - bid + get_fun_effect_info ctx.fun_context.fun_infos (FunId (Regular def_id)) + None bid in let body = translate_expression body ctx in (* Add a match over the fuel, if necessary *) diff --git a/compiler/SynthesizeSymbolic.ml b/compiler/SynthesizeSymbolic.ml index cac56487..aeb6899f 100644 --- a/compiler/SynthesizeSymbolic.ml +++ b/compiler/SynthesizeSymbolic.ml @@ -122,7 +122,7 @@ let synthesize_global_eval (gid : A.GlobalDeclId.id) (dest : V.symbolic_value) (e : expression option) : expression option = Option.map (fun e -> EvalGlobal (gid, dest, e)) e -let synthesize_regular_function_call (fun_id : A.fun_id) +let synthesize_regular_function_call (fun_id : A.fun_id_or_trait_method_ref) (call_id : V.FunCallId.id) (ctx : Contexts.eval_ctx) (abstractions : V.AbstractionId.id list) (generics : T.egeneric_args) (args : V.typed_value list) (args_places : mplace option list) -- cgit v1.3.1 From f11d5186b467df318f7c09eedf8b5629c165b453 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Fri, 20 Oct 2023 15:05:00 +0200 Subject: Start updating to handle function pointers --- compiler/AssociatedTypes.ml | 12 +++++- compiler/Assumed.ml | 2 +- compiler/Extract.ml | 4 +- compiler/ExtractBase.ml | 2 +- compiler/FunsAnalysis.ml | 2 +- compiler/InterpreterExpansion.ml | 2 +- compiler/InterpreterExpressions.ml | 9 +++-- compiler/InterpreterStatements.ml | 78 +++++++++++++++++++++----------------- compiler/InterpreterUtils.ml | 5 +++ compiler/Print.ml | 23 +++++++++++ compiler/PrintPure.ml | 22 +++++------ compiler/PureMicroPasses.ml | 32 ++++++++-------- compiler/SymbolicToPure.ml | 50 +++++++++++++----------- compiler/SynthesizeSymbolic.ml | 2 +- compiler/Translate.ml | 10 ++--- compiler/TypesAnalysis.ml | 8 ++++ 16 files changed, 163 insertions(+), 100 deletions(-) (limited to 'compiler/SynthesizeSymbolic.ml') diff --git a/compiler/AssociatedTypes.ml b/compiler/AssociatedTypes.ml index 992dade9..022aad2f 100644 --- a/compiler/AssociatedTypes.ml +++ b/compiler/AssociatedTypes.ml @@ -157,7 +157,8 @@ let ctx_add_norm_trait_types_from_preds (ctx : C.eval_ctx) let rec trait_instance_id_is_local_clause (id : 'r T.trait_instance_id) : bool = match id with | T.Self | Clause _ -> true - | TraitImpl _ | BuiltinOrAuto _ | TraitRef _ | UnknownTrait _ -> false + | TraitImpl _ | BuiltinOrAuto _ | TraitRef _ | UnknownTrait _ | FnPointer _ -> + false | ParentClause (id, _, _) | ItemClause (id, _, _, _) -> trait_instance_id_is_local_clause id @@ -187,6 +188,10 @@ let rec ctx_normalize_ty : 'r. 'r norm_ctx -> 'r T.ty -> 'r T.ty = | Ref (r, ty, rkind) -> let ty = ctx_normalize_ty ctx ty in T.Ref (r, ty, rkind) + | Arrow (inputs, output) -> + let inputs = List.map (ctx_normalize_ty ctx) inputs in + let output = ctx_normalize_ty ctx output in + Arrow (inputs, output) | TraitType (trait_ref, generics, type_name) -> ( log#ldebug (lazy @@ -401,6 +406,11 @@ and ctx_normalize_trait_instance_id : assert (trait_instance_id_is_local_clause trait_ref.trait_id); assert (trait_ref.generics = TypesUtils.mk_empty_generic_args); (trait_ref.trait_id, None) + | FnPointer ty -> + let ty = ctx_normalize_ty ctx ty in + (* TODO: we might want to return the ref to the function pointer, + in order to later normalize a call to this function pointer *) + (FnPointer ty, None) | UnknownTrait _ -> (* This is actually an error case *) (id, None) diff --git a/compiler/Assumed.ml b/compiler/Assumed.ml index 109175af..b1ec0660 100644 --- a/compiler/Assumed.ml +++ b/compiler/Assumed.ml @@ -347,7 +347,7 @@ let assumed_infos : assumed_info list = let vec_pre = [ "alloc"; "vec"; "Vec" ] in let index_pre = [ "core"; "ops"; "index" ] in [ - (A.Replace, Sig.mem_replace_sig, false, to_name [ "core"; "mem"; "replace" ]); + (Replace, Sig.mem_replace_sig, false, to_name [ "core"; "mem"; "replace" ]); (BoxNew, Sig.box_new_sig, false, to_name [ "alloc"; "boxed"; "Box"; "new" ]); ( BoxFree, Sig.box_free_sig, diff --git a/compiler/Extract.ml b/compiler/Extract.ml index ac81d6f3..688f6ce3 100644 --- a/compiler/Extract.ml +++ b/compiler/Extract.ml @@ -2696,7 +2696,7 @@ and extract_function_call (ctx : extraction_ctx) (fmt : F.formatter) (* Provided method: we see it as a regular function call, and use the function name *) let fun_id = - FromLlbc (FunId (A.Regular method_id.id), lp_id, rg_id) + FromLlbc (FunId (Regular method_id.id), lp_id, rg_id) in let fun_name = ctx_get_function with_opaque_pre fun_id ctx in F.pp_print_string fmt fun_name; @@ -3519,7 +3519,7 @@ let extract_fun_comment (ctx : extraction_ctx) (fmt : F.formatter) (def : fun_decl) : unit = let { keep_fwd; num_backs } = PureUtils.RegularFunIdMap.find - (Pure.FunId (A.Regular def.def_id), def.loop_id, def.back_id) + (Pure.FunId (Regular def.def_id), def.loop_id, def.back_id) ctx.fun_name_info in let comment_pre = "[" ^ Print.fun_name_to_string def.basename ^ "]: " in diff --git a/compiler/ExtractBase.ml b/compiler/ExtractBase.ml index 1586e6ed..a921515b 100644 --- a/compiler/ExtractBase.ml +++ b/compiler/ExtractBase.ml @@ -1482,7 +1482,7 @@ let initialize_names_map (fmt : formatter) (init : names_map_init) : names_map = let assumed_functions = List.map (fun (fid, rg, name) -> - (FromLlbc (Pure.FunId (A.Assumed fid), None, rg), name)) + (FromLlbc (Pure.FunId (Assumed fid), None, rg), name)) init.assumed_llbc_functions @ List.map (fun (fid, name) -> (Pure fid, name)) init.assumed_pure_functions in diff --git a/compiler/FunsAnalysis.ml b/compiler/FunsAnalysis.ml index f4406653..a09a6d05 100644 --- a/compiler/FunsAnalysis.ml +++ b/compiler/FunsAnalysis.ml @@ -76,7 +76,7 @@ let analyze_module (m : crate) (funs_map : fun_decl FunDeclId.Map.t) can_fail := EU.binop_can_fail bop || !can_fail method! visit_Call env call = - (match call.func with + (match call.func.func with | FunId (Regular id) -> if FunDeclId.Set.mem id fun_ids then ( can_diverge := true; diff --git a/compiler/InterpreterExpansion.ml b/compiler/InterpreterExpansion.ml index ea692386..c1041fa3 100644 --- a/compiler/InterpreterExpansion.ml +++ b/compiler/InterpreterExpansion.ml @@ -709,7 +709,7 @@ let greedy_expand_symbolics_with_borrows (config : C.config) : cm_fun = raise (Failure "Attempted to greedily expand an ADT which can't be expanded ") - | T.TypeVar _ | T.Literal _ | Never | T.TraitType _ -> + | T.TypeVar _ | T.Literal _ | Never | T.TraitType _ | T.Arrow _ -> raise (Failure "Unreachable") in (* Compose and continue *) diff --git a/compiler/InterpreterExpressions.ml b/compiler/InterpreterExpressions.ml index 29826233..a42c552a 100644 --- a/compiler/InterpreterExpressions.ml +++ b/compiler/InterpreterExpressions.ml @@ -271,7 +271,7 @@ let eval_operand_no_reorganize (config : C.config) (op : E.operand) match cv.value with | E.CLiteral lit -> cf (literal_to_typed_value (TypesUtils.ty_as_literal cv.ty) lit) ctx - | E.TraitConst (trait_ref, generics, const_name) -> ( + | E.CTraitConst (trait_ref, generics, const_name) -> ( assert (generics = TypesUtils.mk_empty_generic_args); match trait_ref.trait_id with | T.TraitImpl _ -> @@ -329,7 +329,8 @@ let eval_operand_no_reorganize (config : C.config) (op : E.operand) None, value_as_symbolic v.value, SymbolicAst.ConstGenericValue vid, - e )))) + e ))) + | E.CFnPtr _ -> raise (Failure "TODO")) | E.Copy p -> (* Access the value *) let access = Read in @@ -426,7 +427,7 @@ let eval_unary_op_concrete (config : C.config) (unop : E.unop) (op : E.operand) match mk_scalar sv.int_ty i with | Error _ -> cf (Error EPanic) | Ok sv -> cf (Ok { v with V.value = V.Literal (PV.Scalar sv) })) - | E.Cast (src_ty, tgt_ty), V.Literal (PV.Scalar sv) -> ( + | E.Cast (E.CastInteger (src_ty, tgt_ty)), V.Literal (PV.Scalar sv) -> ( assert (src_ty = sv.int_ty); let i = sv.PV.value in match mk_scalar tgt_ty i with @@ -452,7 +453,7 @@ let eval_unary_op_symbolic (config : C.config) (unop : E.unop) (op : E.operand) match (unop, v.V.ty) with | E.Not, (T.Literal Bool as lty) -> lty | E.Neg, (T.Literal (Integer _) as lty) -> lty - | E.Cast (_, tgt_ty), _ -> T.Literal (Integer tgt_ty) + | E.Cast (E.CastInteger (_, tgt_ty)), _ -> T.Literal (Integer tgt_ty) | _ -> raise (Failure "Invalid input for unop") in let res_sv = diff --git a/compiler/InterpreterStatements.ml b/compiler/InterpreterStatements.ml index 36bc3492..9f35c6f2 100644 --- a/compiler/InterpreterStatements.ml +++ b/compiler/InterpreterStatements.ml @@ -306,7 +306,7 @@ let get_assumed_function_return_type (ctx : C.eval_ctx) (fid : A.assumed_fun_id) assert (generics.trait_refs = []); (* [Box::free] has a special treatment *) match fid with - | A.BoxFree -> + | BoxFree -> assert (generics.regions = []); assert (List.length generics.types = 1); assert (generics.const_generics = []); @@ -583,7 +583,7 @@ let eval_vec_function_concrete (_config : C.config) (_fid : A.assumed_fun_id) (** Evaluate a non-local function call in concrete mode *) let eval_assumed_function_call_concrete (config : C.config) (fid : A.assumed_fun_id) (call : A.call) : cm_fun = - let generics = call.generics in + let generics = call.func.generics in let args = call.args in let dest = call.dest in (* Sanity check: we don't fully handle the const generic vars environment @@ -595,7 +595,7 @@ let eval_assumed_function_call_concrete (config : C.config) See {!eval_box_free} *) match fid with - | A.BoxFree -> + | BoxFree -> (* Degenerate case: box_free *) eval_box_free config generics args dest | _ -> @@ -636,7 +636,7 @@ let eval_assumed_function_call_concrete (config : C.config) * access to a body. *) let cf_eval_body : cm_fun = match fid with - | A.Replace -> eval_replace_concrete config generics + | Replace -> eval_replace_concrete config generics | BoxNew -> eval_box_new_concrete config generics | BoxDeref -> eval_box_deref_concrete config generics | BoxDerefMut -> eval_box_deref_mut_concrete config generics @@ -854,15 +854,14 @@ and eval_global (config : C.config) (dest : E.place) (gid : LA.GlobalDeclId.id) match config.mode with | ConcreteMode -> (* Treat the evaluation of the global as a call to the global body (without arguments) *) - let call = + let func = { - A.func = A.FunId (A.Regular global.body_id); + E.func = FunId (Regular global.body_id); generics = TypesUtils.mk_empty_generic_args; trait_and_method_generic_args = None; - args = []; - dest; } in + let call = { A.func; args = []; dest } in (eval_transparent_function_call_concrete config global.body_id call) cf ctx | SymbolicMode -> @@ -1019,29 +1018,28 @@ and eval_function_call (config : C.config) (call : A.call) : st_cm_fun = and eval_function_call_concrete (config : C.config) (call : A.call) : st_cm_fun = fun cf ctx -> - match call.func with - | A.FunId (A.Regular fid) -> + match call.func.func with + | FunId (Regular fid) -> eval_transparent_function_call_concrete config fid call cf ctx - | A.FunId (A.Assumed fid) -> + | FunId (Assumed fid) -> (* Continue - note that we do as if the function call has been successful, * by giving {!Unit} to the continuation, because we place us in the case * where we haven't panicked. Of course, the translation needs to take the * panic case into account... *) eval_assumed_function_call_concrete config fid call (cf Unit) ctx - | A.TraitMethod _ -> raise (Failure "Unimplemented") + | TraitMethod _ -> raise (Failure "Unimplemented") and eval_function_call_symbolic (config : C.config) (call : A.call) : st_cm_fun = - match call.func with - | A.FunId (A.Regular _) | A.TraitMethod _ -> + match call.func.func with + | FunId (Regular _) | TraitMethod _ -> eval_transparent_function_call_symbolic config call - | A.FunId (A.Assumed fid) -> - eval_assumed_function_call_symbolic config fid call + | FunId (Assumed fid) -> eval_assumed_function_call_symbolic config fid call (** Evaluate a local (i.e., non-assumed) function call in concrete mode *) and eval_transparent_function_call_concrete (config : C.config) (fid : A.FunDeclId.id) (call : A.call) : st_cm_fun = - let generics = call.A.generics in + let generics = call.func.generics in let args = call.A.args in let dest = call.A.dest in (* Sanity check: we don't fully handle the const generic vars environment @@ -1195,29 +1193,29 @@ and eval_transparent_function_call_symbolic (config : C.config) (call : A.call) to a trait clause but directly to the method provided in the trait declaration. *) let func, generics, def, inst_sg = - match call.func with - | A.FunId (A.Regular fid) -> + match call.func.func with + | FunId (Regular fid) -> let def = C.ctx_lookup_fun_decl ctx fid in let tr_self = T.UnknownTrait __FUNCTION__ in let inst_sg = - instantiate_fun_sig ctx call.generics tr_self def.A.signature + instantiate_fun_sig ctx call.func.generics tr_self def.A.signature in - (call.func, call.generics, def, inst_sg) - | A.FunId (A.Assumed _) -> + (call.func.func, call.func.generics, def, inst_sg) + | FunId (Assumed _) -> (* Unreachable: must be a transparent function *) raise (Failure "Unreachable") - | A.TraitMethod (trait_ref, method_name, _) -> ( + | TraitMethod (trait_ref, method_name, _) -> ( log#ldebug (lazy ("trait method call:\n- call: " ^ call_to_string ctx call ^ "\n- method name: " ^ method_name ^ "\n- call.generics:\n" - ^ egeneric_args_to_string ctx call.generics + ^ egeneric_args_to_string ctx call.func.generics ^ "\n- trait and method generics:\n" ^ egeneric_args_to_string ctx - (Option.get call.trait_and_method_generic_args))); + (Option.get call.func.trait_and_method_generic_args))); (* When instantiating, we need to group the generics for the trait ref and the method *) - let generics = Option.get call.trait_and_method_generic_args in + let generics = Option.get call.func.trait_and_method_generic_args in (* Lookup the trait method signature - there are several possibilities depending on whethere we call a top-level trait method impl or the method from a local clause *) @@ -1251,7 +1249,7 @@ and eval_transparent_function_call_symbolic (config : C.config) (call : A.call) which implements the method. In order to do this properly, we also need to update the generics. *) - let func = A.FunId (A.Regular id) in + let func = E.FunId (Regular id) in (func, generics, method_def, inst_sg) | None -> (* If not found, lookup the methods provided by the trait *declaration* @@ -1287,7 +1285,7 @@ and eval_transparent_function_call_symbolic (config : C.config) (call : A.call) *) let all_generics = TypesUtils.merge_generic_args - trait_ref.trait_decl_ref.decl_generics call.generics + trait_ref.trait_decl_ref.decl_generics call.func.generics in log#ldebug (lazy @@ -1304,7 +1302,7 @@ and eval_transparent_function_call_symbolic (config : C.config) (call : A.call) instantiate_fun_sig ctx all_generics tr_self method_def.A.signature in - (call.func, call.generics, method_def, inst_sg)) + (call.func.func, call.func.generics, method_def, inst_sg)) | _ -> (* We are using a local clause - we lookup the trait decl *) let trait_decl = @@ -1333,7 +1331,7 @@ and eval_transparent_function_call_symbolic (config : C.config) (call : A.call) let inst_sg = instantiate_fun_sig ctx generics tr_self method_def.A.signature in - (call.func, call.generics, method_def, inst_sg)) + (call.func.func, call.func.generics, method_def, inst_sg)) in (* Sanity check *) assert (List.length call.args = List.length def.A.signature.inputs); @@ -1357,6 +1355,18 @@ and eval_function_call_symbolic_from_inst_sig (config : C.config) (generics : T.egeneric_args) (args : E.operand list) (dest : E.place) : st_cm_fun = fun cf ctx -> + log#ldebug + (lazy + ("eval_function_call_symbolic_from_inst_sig:\n- fid: " + ^ fun_id_or_trait_method_ref_to_string ctx fid + ^ "\n- inst_sg:\n" + ^ inst_fun_sig_to_string ctx inst_sg + ^ "\n- call.generics:\n" + ^ egeneric_args_to_string ctx generics + ^ "\n- args:\n" + ^ String.concat ", " (List.map (operand_to_string ctx) args) + ^ "\n- dest:\n" ^ place_to_string ctx dest)); + (* Generate a fresh symbolic value for the return value *) let ret_sv_ty = inst_sg.A.output in let ret_spc = mk_fresh_symbolic_value V.FunCallRet ret_sv_ty in @@ -1487,7 +1497,7 @@ and eval_function_call_symbolic_from_inst_sig (config : C.config) and eval_assumed_function_call_symbolic (config : C.config) (fid : A.assumed_fun_id) (call : A.call) : st_cm_fun = fun cf ctx -> - let generics = call.generics in + let generics = call.func.generics in let args = call.args in let dest = call.dest in (* Sanity check: make sure the type parameters don't contain regions - @@ -1503,7 +1513,7 @@ and eval_assumed_function_call_symbolic (config : C.config) See {!eval_box_free} *) match fid with - | A.BoxFree -> + | BoxFree -> (* Degenerate case: box_free - note that this is not really a function * call: no need to call a "synthesize_..." function *) eval_box_free config generics args dest (cf Unit) ctx @@ -1514,7 +1524,7 @@ and eval_assumed_function_call_symbolic (config : C.config) * instantiated signatures, and delegate the work to an auxiliary function *) let inst_sig = match fid with - | A.BoxFree -> + | BoxFree -> (* should have been treated above *) raise (Failure "Unreachable") | _ -> @@ -1525,7 +1535,7 @@ and eval_assumed_function_call_symbolic (config : C.config) in (* Evaluate the function call *) - eval_function_call_symbolic_from_inst_sig config (A.FunId (A.Assumed fid)) + eval_function_call_symbolic_from_inst_sig config (FunId (Assumed fid)) inst_sig generics args dest cf ctx (** Evaluate a statement seen as a function body *) diff --git a/compiler/InterpreterUtils.ml b/compiler/InterpreterUtils.ml index 7aaee6ff..6e08e553 100644 --- a/compiler/InterpreterUtils.ml +++ b/compiler/InterpreterUtils.ml @@ -46,6 +46,11 @@ let operand_to_string = PA.operand_to_string let egeneric_args_to_string = PA.egeneric_args_to_string let rtrait_instance_id_to_string = PA.rtrait_instance_id_to_string let fun_sig_to_string = PA.fun_sig_to_string +let inst_fun_sig_to_string = PA.inst_fun_sig_to_string + +let fun_id_or_trait_method_ref_to_string = + PA.fun_id_or_trait_method_ref_to_string + let fun_decl_to_string = PA.fun_decl_to_string let call_to_string = PA.call_to_string diff --git a/compiler/Print.ml b/compiler/Print.ml index 5d5c16ee..1d5ddc50 100644 --- a/compiler/Print.ml +++ b/compiler/Print.ml @@ -359,6 +359,18 @@ module Values = struct ^ "}" ^ "{regions=" ^ T.RegionId.Set.to_string None abs.regions ^ "}" ^ " {\n" ^ avs ^ "\n" ^ indent ^ "}" + + let inst_fun_sig_to_string (fmt : value_formatter) (sg : LlbcAst.inst_fun_sig) + : string = + (* TODO: print the trait type constraints? *) + let ty_fmt = value_to_rtype_formatter fmt in + let ty_to_string = PT.ty_to_string ty_fmt in + + let inputs = + "(" ^ String.concat ", " (List.map ty_to_string sg.inputs) ^ ")" + in + let output = ty_to_string sg.output in + inputs ^ " -> " ^ output end module PV = Values (* local module *) @@ -755,6 +767,17 @@ module EvalCtxLlbcAst = struct let fmt = PC.eval_ctx_to_ast_formatter ctx in PA.fun_sig_to_string fmt "" " " x + let inst_fun_sig_to_string (ctx : C.eval_ctx) (x : LlbcAst.inst_fun_sig) : + string = + let fmt = PC.eval_ctx_to_ast_formatter ctx in + let fmt = PC.ast_to_value_formatter fmt in + PV.inst_fun_sig_to_string fmt x + + let fun_id_or_trait_method_ref_to_string (ctx : C.eval_ctx) + (x : E.fun_id_or_trait_method_ref) : string = + let fmt = PC.eval_ctx_to_ast_formatter ctx in + PE.fun_id_or_trait_method_ref_to_string fmt x "..." + let statement_to_string (ctx : C.eval_ctx) (indent : string) (indent_incr : string) (e : A.statement) : string = let fmt = PC.eval_ctx_to_ast_formatter ctx in diff --git a/compiler/PrintPure.ml b/compiler/PrintPure.ml index 5fb5978b..be7b3cb4 100644 --- a/compiler/PrintPure.ml +++ b/compiler/PrintPure.ml @@ -593,17 +593,17 @@ let fun_suffix (lp_id : LoopId.id option) (rg_id : T.RegionGroupId.id option) : let llbc_assumed_fun_id_to_string (fid : A.assumed_fun_id) : string = match fid with - | A.Replace -> "core::mem::replace" - | A.BoxNew -> "alloc::boxed::Box::new" - | A.BoxDeref -> "core::ops::deref::Deref::deref" - | A.BoxDerefMut -> "core::ops::deref::DerefMut::deref_mut" - | A.BoxFree -> "alloc::alloc::box_free" - | A.VecNew -> "alloc::vec::Vec::new" - | A.VecPush -> "alloc::vec::Vec::push" - | A.VecInsert -> "alloc::vec::Vec::insert" - | A.VecLen -> "alloc::vec::Vec::len" - | A.VecIndex -> "core::ops::index::Index::index" - | A.VecIndexMut -> "core::ops::index::IndexMut::index_mut" + | Replace -> "core::mem::replace" + | BoxNew -> "alloc::boxed::Box::new" + | BoxDeref -> "core::ops::deref::Deref::deref" + | BoxDerefMut -> "core::ops::deref::DerefMut::deref_mut" + | BoxFree -> "alloc::alloc::box_free" + | VecNew -> "alloc::vec::Vec::new" + | VecPush -> "alloc::vec::Vec::push" + | VecInsert -> "alloc::vec::Vec::insert" + | VecLen -> "alloc::vec::Vec::len" + | VecIndex -> "core::ops::index::Index::index" + | VecIndexMut -> "core::ops::index::IndexMut::index_mut" | ArrayIndexShared -> "@ArrayIndexShared" | ArrayIndexMut -> "@ArrayIndexMut" | ArrayToSliceShared -> "@ArrayToSliceShared" diff --git a/compiler/PureMicroPasses.ml b/compiler/PureMicroPasses.ml index cedc3559..b00509a6 100644 --- a/compiler/PureMicroPasses.ml +++ b/compiler/PureMicroPasses.ml @@ -791,7 +791,7 @@ let expression_contains_child_call_in_all_paths (ctx : trans_ctx) let id0 = match id0 with | FunId fun_id -> fun_id - | TraitMethod (_, _, fun_decl_id) -> A.Regular fun_decl_id + | TraitMethod (_, _, fun_decl_id) -> Regular fun_decl_id in LlbcAstUtils.lookup_fun_sig id0 ctx.fun_ctx.fun_decls in @@ -1523,29 +1523,29 @@ let eliminate_box_functions (_ctx : trans_ctx) (def : fun_decl) : fun_decl = match opt_destruct_function_call e with | Some (fun_id, _tys, args) -> ( match fun_id with - | Fun (FromLlbc (FunId (A.Assumed aid), _lp_id, rg_id)) -> ( + | Fun (FromLlbc (FunId (Assumed aid), _lp_id, rg_id)) -> ( (* Below, when dealing with the arguments: we consider the very * general case, where functions could be boxed (meaning we * could have: [box_new f x]) * *) match (aid, rg_id) with - | A.BoxNew, _ -> + | BoxNew, _ -> assert (rg_id = None); let arg, args = Collections.List.pop args in mk_apps arg args - | A.BoxDeref, None -> + | BoxDeref, None -> (* [Box::deref] forward is the identity *) let arg, args = Collections.List.pop args in mk_apps arg args - | A.BoxDeref, Some _ -> + | BoxDeref, Some _ -> (* [Box::deref] backward is [()] (doesn't give back anything) *) assert (args = []); mk_unit_rvalue - | A.BoxDerefMut, None -> + | BoxDerefMut, None -> (* [Box::deref_mut] forward is the identity *) let arg, args = Collections.List.pop args in mk_apps arg args - | A.BoxDerefMut, Some _ -> + | BoxDerefMut, Some _ -> (* [Box::deref_mut] back is almost the identity: * let box_deref_mut (x_init : t) (x_back : t) : t = x_back * *) @@ -1555,15 +1555,15 @@ let eliminate_box_functions (_ctx : trans_ctx) (def : fun_decl) : fun_decl = | _ -> raise (Failure "Unreachable") in mk_apps arg args - | A.BoxFree, _ -> + | BoxFree, _ -> assert (args = []); mk_unit_rvalue - | ( ( A.Replace | VecNew | VecPush | VecInsert | VecLen - | VecIndex | VecIndexMut | ArraySubsliceShared - | ArraySubsliceMut | SliceIndexShared | SliceIndexMut - | SliceSubsliceShared | SliceSubsliceMut | ArrayIndexShared - | ArrayIndexMut | ArrayToSliceShared | ArrayToSliceMut - | ArrayRepeat | SliceLen ), + | ( ( Replace | VecNew | VecPush | VecInsert | VecLen | VecIndex + | VecIndexMut | ArraySubsliceShared | ArraySubsliceMut + | SliceIndexShared | SliceIndexMut | SliceSubsliceShared + | SliceSubsliceMut | ArrayIndexShared | ArrayIndexMut + | ArrayToSliceShared | ArrayToSliceMut | ArrayRepeat + | SliceLen ), _ ) -> super#visit_texpression env e) | _ -> super#visit_texpression env e) @@ -2046,7 +2046,7 @@ let filter_loop_inputs (transl : pure_fun_translation list) : let inputs_set = VarId.Set.of_list (List.map var_get_id inputs_prefix) in assert (Option.is_some decl.loop_id); - let fun_id = (A.Regular decl.def_id, decl.loop_id) in + let fun_id = (E.Regular decl.def_id, decl.loop_id) in let set_used vid = used := List.map (fun (vid', b) -> (vid', b || vid = vid')) !used @@ -2130,7 +2130,7 @@ let filter_loop_inputs (transl : pure_fun_translation list) : (* We then apply the filtering to all the function definitions at once *) let filter_in_one (decl : fun_decl) : fun_decl = (* Filter the function signature *) - let fun_id = (A.Regular decl.def_id, decl.loop_id) in + let fun_id = (E.Regular decl.def_id, decl.loop_id) in let decl = match FunLoopIdMap.find_opt fun_id !used_map with | None -> (* Nothing to filter *) decl diff --git a/compiler/SymbolicToPure.ml b/compiler/SymbolicToPure.ml index 429198ad..54221cb1 100644 --- a/compiler/SymbolicToPure.ml +++ b/compiler/SymbolicToPure.ml @@ -343,7 +343,7 @@ let bs_ctx_lookup_llbc_fun_decl (id : A.FunDeclId.id) (ctx : bs_ctx) : (* TODO: move *) let bs_ctx_lookup_local_function_sig (def_id : A.FunDeclId.id) (back_id : T.RegionGroupId.id option) (ctx : bs_ctx) : fun_sig = - let id = (A.Regular def_id, back_id) in + let id = (E.Regular def_id, back_id) in (RegularFunIdNotLoopMap.find id ctx.fun_context.fun_sigs).sg (* Some generic translation functions (we need to translate different "flavours" @@ -390,6 +390,7 @@ and translate_trait_instance_id (translate_ty : 'r T.ty -> ty) let inst_id = translate_trait_instance_id inst_id in ItemClause (inst_id, decl_id, item_name, clause_id) | TraitRef tr -> TraitRef (translate_trait_ref translate_ty tr) + | FnPointer _ -> raise (Failure "TODO") | UnknownTrait s -> raise (Failure ("Unknown trait found: " ^ s)) let rec translate_sty (ty : T.sty) : ty = @@ -427,6 +428,7 @@ let rec translate_sty (ty : T.sty) : ty = let trait_ref = translate_strait_ref trait_ref in let generics = translate_sgeneric_args generics in TraitType (trait_ref, generics, type_name) + | Arrow _ -> raise (Failure "TODO") and translate_sgeneric_args (generics : T.sgeneric_args) : generic_args = translate_generic_args translate_sty generics @@ -569,6 +571,7 @@ let rec translate_fwd_ty (type_infos : TA.type_infos) (ty : 'r T.ty) : ty = let trait_ref = translate_fwd_trait_ref type_infos trait_ref in let generics = translate_fwd_generic_args type_infos generics in TraitType (trait_ref, generics, type_name) + | Arrow _ -> raise (Failure "TODO") and translate_fwd_generic_args (type_infos : TA.type_infos) (generics : 'r T.generic_args) : generic_args = @@ -658,6 +661,7 @@ let rec translate_back_ty (type_infos : TA.type_infos) let trait_ref = translate_fwd_trait_ref type_infos trait_ref in let generics = translate_fwd_generic_args type_infos generics in Some (TraitType (trait_ref, generics, type_name)) + | Arrow _ -> raise (Failure "TODO") (** Simply calls [translate_back_ty] *) let ctx_translate_back_ty (ctx : bs_ctx) (keep_region : 'r -> bool) @@ -694,7 +698,7 @@ let type_check_texpression (ctx : bs_ctx) (e : texpression) : unit = let translate_fun_id_or_trait_method_ref (ctx : bs_ctx) (id : A.fun_id_or_trait_method_ref) : fun_id_or_trait_method_ref = match id with - | A.FunId fun_id -> FunId fun_id + | FunId fun_id -> FunId fun_id | TraitMethod (trait_ref, method_name, fun_decl_id) -> let type_infos = ctx.type_context.type_infos in let trait_ref = translate_fwd_trait_ref type_infos trait_ref in @@ -795,7 +799,7 @@ let get_fun_effect_info (fun_infos : FA.fun_info A.FunDeclId.Map.t) (fun_id : A.fun_id_or_trait_method_ref) (lid : V.LoopId.id option) (gid : T.RegionGroupId.id option) : fun_effect_info = match fun_id with - | A.TraitMethod (_, _, fid) | A.FunId (A.Regular fid) -> + | TraitMethod (_, _, fid) | FunId (Regular fid) -> let info = A.FunDeclId.Map.find fid fun_infos in let stateful_group = info.stateful in let stateful = @@ -808,7 +812,7 @@ let get_fun_effect_info (fun_infos : FA.fun_info A.FunDeclId.Map.t) can_diverge = info.can_diverge; is_rec = info.is_rec || Option.is_some lid; } - | A.FunId (A.Assumed aid) -> + | FunId (Assumed aid) -> assert (lid = None); { can_fail = Assumed.assumed_can_fail aid; @@ -841,7 +845,7 @@ let translate_fun_sig (decls_ctx : C.decls_ctx) (fun_id : A.fun_id) in (* Is the function stateful, and can it fail? *) let lid = None in - let effect_info = get_fun_effect_info fun_infos (A.FunId fun_id) lid bid in + let effect_info = get_fun_effect_info fun_infos (FunId fun_id) lid bid in (* We need an evaluation context to normalize the types (to normalize the associated types, etc. - for instance it may happen that the types refer to the types associated to a trait ref, but where the trait ref @@ -1706,18 +1710,20 @@ and translate_function_call (call : S.call) (e : S.expression) (ctx : bs_ctx) : in (ctx, Unop (Neg int_ty), effect_info, args, None) | _ -> raise (Failure "Unreachable")) - | S.Unop (E.Cast (src_ty, tgt_ty)) -> - (* Note that cast can fail *) - let effect_info = - { - can_fail = true; - stateful_group = false; - stateful = false; - can_diverge = false; - is_rec = false; - } - in - (ctx, Unop (Cast (src_ty, tgt_ty)), effect_info, args, None) + | S.Unop (E.Cast cast_kind) -> ( + match cast_kind with + | CastInteger (src_ty, tgt_ty) -> + (* Note that cast can fail *) + let effect_info = + { + can_fail = true; + stateful_group = false; + stateful = false; + can_diverge = false; + is_rec = false; + } + in + (ctx, Unop (Cast (src_ty, tgt_ty)), effect_info, args, None)) | S.Binop binop -> ( match args with | [ arg0; arg1 ] -> @@ -1925,7 +1931,7 @@ and translate_end_abstraction_fun_call (ectx : C.eval_ctx) (abs : V.abs) (* Sanity check: there is the proper number of inputs and outputs, and they have the proper type *) (if (* TODO: normalize the types *) !Config.type_check_pure_code then match fun_id with - | A.FunId fun_id -> + | FunId fun_id -> let inst_sg = get_instantiated_fun_sig fun_id (Some rg_id) generics ctx in @@ -2088,9 +2094,9 @@ and translate_end_abstraction_loop (ectx : C.eval_ctx) (abs : V.abs) (* Actually the same case as [SynthInput] *) translate_end_abstraction_synth_input ectx abs e ctx rg_id | V.LoopCall -> - let fun_id = A.Regular ctx.fun_decl.A.def_id in + let fun_id = E.Regular ctx.fun_decl.A.def_id in let effect_info = - get_fun_effect_info ctx.fun_context.fun_infos (A.FunId fun_id) + get_fun_effect_info ctx.fun_context.fun_infos (FunId fun_id) (Some vloop_id) (Some rg_id) in let loop_info = LoopId.Map.find loop_id ctx.loops in @@ -2553,9 +2559,9 @@ and translate_forward_end (ectx : C.eval_ctx) let org_args = args in (* Lookup the effect info for the loop function *) - let fid = A.Regular ctx.fun_decl.A.def_id in + let fid = E.Regular ctx.fun_decl.A.def_id in let effect_info = - get_fun_effect_info ctx.fun_context.fun_infos (A.FunId fid) None ctx.bid + get_fun_effect_info ctx.fun_context.fun_infos (FunId fid) None ctx.bid in (* Introduce a fresh output value for the forward function *) diff --git a/compiler/SynthesizeSymbolic.ml b/compiler/SynthesizeSymbolic.ml index aeb6899f..9084f2b3 100644 --- a/compiler/SynthesizeSymbolic.ml +++ b/compiler/SynthesizeSymbolic.ml @@ -85,7 +85,7 @@ let synthesize_symbolic_expansion (sv : V.symbolic_value) match ls with | [ (Some see, exp) ] -> ExpandNoBranch (see, exp) | _ -> raise (Failure "Ill-formed borrow expansion")) - | T.TypeVar _ | T.Literal Char | Never | T.TraitType _ -> + | T.TypeVar _ | T.Literal Char | Never | T.TraitType _ | T.Arrow _ -> raise (Failure "Ill-formed symbolic expansion") in Some (Expansion (place, sv, expansion)) diff --git a/compiler/Translate.ml b/compiler/Translate.ml index e69abee1..8e01c869 100644 --- a/compiler/Translate.ml +++ b/compiler/Translate.ml @@ -61,7 +61,7 @@ let translate_function_to_pure (trans_ctx : trans_ctx) (* Initialize the context *) let forward_sig = - RegularFunIdNotLoopMap.find (A.Regular def_id, None) fun_sigs + RegularFunIdNotLoopMap.find (E.Regular def_id, None) fun_sigs in let sv_to_var = V.SymbolicValueId.Map.empty in let var_counter = Pure.VarId.generator_zero in @@ -200,7 +200,7 @@ let translate_function_to_pure (trans_ctx : trans_ctx) (* Initialize the context - note that the ret_ty is not really * useful as we don't translate a body *) let backward_sg = - RegularFunIdNotLoopMap.find (A.Regular def_id, Some back_id) fun_sigs + RegularFunIdNotLoopMap.find (Regular def_id, Some back_id) fun_sigs in let ctx = { ctx with bid = Some back_id; sg = backward_sg.sg } in @@ -211,7 +211,7 @@ let translate_function_to_pure (trans_ctx : trans_ctx) variables required by the backward function. *) let backward_sg = - RegularFunIdNotLoopMap.find (A.Regular def_id, Some back_id) fun_sigs + RegularFunIdNotLoopMap.find (Regular def_id, Some back_id) fun_sigs in (* We need to ignore the forward inputs, and the state input (if there is) *) let backward_inputs = @@ -298,7 +298,7 @@ let translate_crate_to_pure (crate : A.crate) : let assumed_sigs = List.map (fun (id, sg, _, _) -> - (A.Assumed id, List.map (fun _ -> None) (sg : A.fun_sig).inputs, sg)) + (E.Assumed id, List.map (fun _ -> None) (sg : A.fun_sig).inputs, sg)) Assumed.assumed_infos in let local_sigs = @@ -312,7 +312,7 @@ let translate_crate_to_pure (crate : A.crate) : (fun (v : A.var) -> v.name) (LlbcAstUtils.fun_body_get_input_vars body) in - (A.Regular fdef.def_id, input_names, fdef.signature)) + (E.Regular fdef.def_id, input_names, fdef.signature)) (A.FunDeclId.Map.values crate.functions) in let sigs = List.append assumed_sigs local_sigs in diff --git a/compiler/TypesAnalysis.ml b/compiler/TypesAnalysis.ml index 95c7206a..4a187893 100644 --- a/compiler/TypesAnalysis.ml +++ b/compiler/TypesAnalysis.ml @@ -232,6 +232,14 @@ let analyze_full_ty (r_is_static : 'r -> bool) (updated : bool ref) in (* Return *) ty_info + | Arrow (inputs, output) -> + (* Just dive into the arrow *) + let ty_info = + List.fold_left + (fun ty_info ty -> analyze expl_info ty_info ty) + ty_info inputs + in + analyze expl_info ty_info output in (* Explore *) analyze expl_info_init ty_info ty -- cgit v1.3.1 From ece74df70f12790bab7ecfe0c590c2c637e89801 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Wed, 25 Oct 2023 11:40:31 +0200 Subject: Update following the addition of raw pointers --- compiler/Assumed.ml | 1 + compiler/Extract.ml | 5 ++++- compiler/ExtractBase.ml | 5 +++-- compiler/InterpreterExpansion.ml | 3 ++- compiler/Print.ml | 30 ++++++++++++++++++++++++------ compiler/PrintPure.ml | 8 +++++--- compiler/Pure.ml | 18 +++++++++++++++++- compiler/PureTypeCheck.ml | 2 +- compiler/SymbolicToPure.ml | 13 +++++++++++++ compiler/SynthesizeSymbolic.ml | 4 +++- compiler/TypesAnalysis.ml | 3 +++ compiler/dune | 2 +- 12 files changed, 77 insertions(+), 17 deletions(-) (limited to 'compiler/SynthesizeSymbolic.ml') diff --git a/compiler/Assumed.ml b/compiler/Assumed.ml index 94fb7a72..79f6b0d4 100644 --- a/compiler/Assumed.ml +++ b/compiler/Assumed.ml @@ -85,6 +85,7 @@ module Sig = struct { regions_outlive = []; types_outlive = []; trait_type_constraints = [] } in { + is_unsafe = false; generics; preds; parent_params_info = None; diff --git a/compiler/Extract.ml b/compiler/Extract.ml index 91827a31..afd722e5 100644 --- a/compiler/Extract.ml +++ b/compiler/Extract.ml @@ -64,7 +64,9 @@ let named_binop_name (binop : E.binop) (int_ty : integer_type) : string = | BitAnd -> "and" | BitOr -> "or" | Shl -> "lsl" - | Shr -> "asr" (* NOTE: make sure arithmetic shift right is implemented, i.e. OCaml's asr operator, not lsr *) + | Shr -> + "asr" + (* NOTE: make sure arithmetic shift right is implemented, i.e. OCaml's asr operator, not lsr *) | _ -> raise (Failure "Unreachable") in (* Remark: the Lean case is actually not used *) @@ -798,6 +800,7 @@ let mk_formatter (ctx : trans_ctx) (crate_name : string) | Assumed Slice -> "s" | Assumed Str -> "s" | Assumed State -> ConstStrings.state_basename + | Assumed (RawPtr _) -> "p" | AdtId adt_id -> let def = TypeDeclId.Map.find adt_id ctx.type_ctx.type_decls in (* Derive the var name from the last ident of the type name diff --git a/compiler/ExtractBase.ml b/compiler/ExtractBase.ml index 8f32ba44..3eef6b3b 100644 --- a/compiler/ExtractBase.ml +++ b/compiler/ExtractBase.ml @@ -758,7 +758,7 @@ let id_to_string (id : id) (ctx : extraction_ctx) : string = if variant_id = fuel_zero_id then "@fuel::0" else if variant_id = fuel_succ_id then "@fuel::Succ" else raise (Failure "Unreachable") - | Assumed (State | Array | Slice | Str) -> + | Assumed (State | Array | Slice | Str | RawPtr _) -> raise (Failure ("Unreachable: variant id (" @@ -777,7 +777,8 @@ let id_to_string (id : id) (ctx : extraction_ctx) : string = let field_name = match id with | Tuple -> raise (Failure "Unreachable") - | Assumed (State | Result | Error | Fuel | Array | Slice | Str) -> + | Assumed + (State | Result | Error | Fuel | Array | Slice | Str | RawPtr _) -> (* We can't directly have access to the fields of those types *) raise (Failure "Unreachable") | AdtId id -> ( diff --git a/compiler/InterpreterExpansion.ml b/compiler/InterpreterExpansion.ml index 167e3d58..b267bb51 100644 --- a/compiler/InterpreterExpansion.ml +++ b/compiler/InterpreterExpansion.ml @@ -696,7 +696,8 @@ let greedy_expand_symbolics_with_borrows (config : C.config) : cm_fun = raise (Failure "Attempted to greedily expand an ADT which can't be expanded ") - | T.TypeVar _ | T.Literal _ | Never | T.TraitType _ | T.Arrow _ -> + | T.TypeVar _ | T.Literal _ | Never | T.TraitType _ | T.Arrow _ + | T.RawPtr _ -> raise (Failure "Unreachable") in (* Compose and continue *) diff --git a/compiler/Print.ml b/compiler/Print.ml index aeacfbf0..7f0d95ff 100644 --- a/compiler/Print.ml +++ b/compiler/Print.ml @@ -660,6 +660,30 @@ module EvalCtxLlbcAst = struct let fmt = PC.ctx_to_stype_formatter fmt in PT.sty_to_string fmt t + let generic_params_to_strings (ctx : C.eval_ctx) (x : T.generic_params) : + string list * string list = + let fmt = PC.eval_ctx_to_ctx_formatter ctx in + let fmt = PC.ctx_to_stype_formatter fmt in + PT.generic_params_to_strings fmt x + + let egeneric_args_to_string (ctx : C.eval_ctx) (x : T.egeneric_args) : string + = + let fmt = PC.eval_ctx_to_ctx_formatter ctx in + let fmt = PC.ctx_to_etype_formatter fmt in + PT.egeneric_args_to_string fmt x + + let rgeneric_args_to_string (ctx : C.eval_ctx) (x : T.rgeneric_args) : string + = + let fmt = PC.eval_ctx_to_ctx_formatter ctx in + let fmt = PC.ctx_to_rtype_formatter fmt in + PT.rgeneric_args_to_string fmt x + + let sgeneric_args_to_string (ctx : C.eval_ctx) (x : T.sgeneric_args) : string + = + let fmt = PC.eval_ctx_to_ctx_formatter ctx in + let fmt = PC.ctx_to_stype_formatter fmt in + PT.sgeneric_args_to_string fmt x + let etrait_ref_to_string (ctx : C.eval_ctx) (x : T.etrait_ref) : string = let fmt = PC.eval_ctx_to_ctx_formatter ctx in let fmt = PC.ctx_to_etype_formatter fmt in @@ -693,12 +717,6 @@ module EvalCtxLlbcAst = struct let fmt = PC.ctx_to_stype_formatter fmt in PT.strait_instance_id_to_string fmt x - let egeneric_args_to_string (ctx : C.eval_ctx) (x : T.egeneric_args) : string - = - let fmt = PC.eval_ctx_to_ctx_formatter ctx in - let fmt = PC.ctx_to_etype_formatter fmt in - PT.egeneric_args_to_string fmt x - let borrow_content_to_string (ctx : C.eval_ctx) (bc : V.borrow_content) : string = let fmt = PC.eval_ctx_to_ctx_formatter ctx in diff --git a/compiler/PrintPure.ml b/compiler/PrintPure.ml index 6396fe96..ec75fcfd 100644 --- a/compiler/PrintPure.ml +++ b/compiler/PrintPure.ml @@ -198,6 +198,8 @@ let assumed_ty_to_string (aty : assumed_ty) : string = | Array -> "Array" | Slice -> "Slice" | Str -> "Str" + | RawPtr Mut -> "MutRawPtr" + | RawPtr Const -> "ConstRawPtr" let type_id_to_string (fmt : type_formatter) (id : type_id) : string = match id with @@ -385,7 +387,7 @@ let adt_variant_to_string (fmt : value_formatter) (adt_id : type_id) | Assumed aty -> ( (* Assumed type *) match aty with - | State | Array | Slice | Str -> + | State | Array | Slice | Str | RawPtr _ -> (* Those types are opaque: we can't get there *) raise (Failure "Unreachable") | Result -> @@ -423,7 +425,7 @@ let adt_field_to_string (fmt : value_formatter) (adt_id : type_id) | State | Fuel | Array | Slice | Str -> (* Opaque types: we can't get there *) raise (Failure "Unreachable") - | Result | Error -> + | Result | Error | RawPtr _ -> (* Enumerations: we can't get there *) raise (Failure "Unreachable")) @@ -463,7 +465,7 @@ let adt_g_value_to_string (fmt : value_formatter) | Adt (Assumed aty, _) -> ( (* Assumed type *) match aty with - | State -> + | State | RawPtr _ -> (* This type is opaque: we can't get there *) raise (Failure "Unreachable") | Result -> diff --git a/compiler/Pure.ml b/compiler/Pure.ml index 81e13af7..9a3654b8 100644 --- a/compiler/Pure.ml +++ b/compiler/Pure.ml @@ -47,6 +47,7 @@ type trait_clause_id = T.trait_clause_id [@@deriving show, ord] type trait_item_name = T.trait_item_name [@@deriving show, ord] type global_decl_id = T.global_decl_id [@@deriving show, ord] type fun_decl_id = A.fun_decl_id [@@deriving show, ord] +type mutability = Mut | Const [@@deriving show, ord] (** The assumed types for the pure AST. @@ -64,7 +65,22 @@ type fun_decl_id = A.fun_decl_id [@@deriving show, ord] this state is opaque to Aeneas (the user can define it, or leave it as assumed) *) -type assumed_ty = State | Result | Error | Fuel | Array | Slice | Str +type assumed_ty = + | State + | Result + | Error + | Fuel + | Array + | Slice + | Str + | RawPtr of mutability + (** The bool + Raw pointers don't make sense in the pure world, but we don't know + how to translate them yet and we have to handle some functions which + use raw pointers in their signature (for instance some trait declarations + for the slices). For now, we use a dedicated type to "mark" the raw pointers, + and make sure that those functions are actually not used in the translation. + *) [@@deriving show, ord] (* TODO: we should never directly manipulate [Return] and [Fail], but rather diff --git a/compiler/PureTypeCheck.ml b/compiler/PureTypeCheck.ml index d31f0cf9..2ad942bb 100644 --- a/compiler/PureTypeCheck.ml +++ b/compiler/PureTypeCheck.ml @@ -46,7 +46,7 @@ let get_adt_field_types (type_decls : type_decl TypeDeclId.Map.t) if variant_id = fuel_zero_id then [] else if variant_id = fuel_succ_id then [ mk_fuel_ty ] else raise (Failure "Unreachable: improper variant id for fuel type") - | Array | Slice | Str -> + | Array | Slice | Str | RawPtr _ -> (* Array: when not symbolic values (for instance, because of aggregates), the array expressions are introduced as struct updates *) raise (Failure "Attempting to access the fields of an opaque type")) diff --git a/compiler/SymbolicToPure.ml b/compiler/SymbolicToPure.ml index 9c698b51..4ba5296f 100644 --- a/compiler/SymbolicToPure.ml +++ b/compiler/SymbolicToPure.ml @@ -421,6 +421,11 @@ let rec translate_sty (ty : T.sty) : ty = | Literal ty -> Literal ty | Never -> raise (Failure "Unreachable") | Ref (_, rty, _) -> translate rty + | RawPtr (ty, rkind) -> + let mut = match rkind with Mut -> Mut | Shared -> Const in + let ty = translate ty in + let generics = { types = [ ty ]; const_generics = []; trait_refs = [] } in + Adt (Assumed (RawPtr mut), generics) | TraitType (trait_ref, generics, type_name) -> let trait_ref = translate_strait_ref trait_ref in let generics = translate_sgeneric_args generics in @@ -560,6 +565,11 @@ let rec translate_fwd_ty (type_infos : TA.type_infos) (ty : 'r T.ty) : ty = | Never -> raise (Failure "Unreachable") | Literal lty -> Literal lty | Ref (_, rty, _) -> translate rty + | RawPtr (ty, rkind) -> + let mut = match rkind with Mut -> Mut | Shared -> Const in + let ty = translate ty in + let generics = { types = [ ty ]; const_generics = []; trait_refs = [] } in + Adt (Assumed (RawPtr mut), generics) | TraitType (trait_ref, generics, type_name) -> let trait_ref = translate_fwd_trait_ref type_infos trait_ref in let generics = translate_fwd_generic_args type_infos generics in @@ -646,6 +656,9 @@ let rec translate_back_ty (type_infos : TA.type_infos) if keep_region r then translate_back_ty type_infos keep_region inside_mut rty else None) + | RawPtr _ -> + (* TODO: not sure what to do here *) + None | TraitType (trait_ref, generics, type_name) -> assert (generics.regions = []); (* Translate the trait ref and the generics as "forward" generics - diff --git a/compiler/SynthesizeSymbolic.ml b/compiler/SynthesizeSymbolic.ml index 9084f2b3..9dd65c84 100644 --- a/compiler/SynthesizeSymbolic.ml +++ b/compiler/SynthesizeSymbolic.ml @@ -85,7 +85,9 @@ let synthesize_symbolic_expansion (sv : V.symbolic_value) match ls with | [ (Some see, exp) ] -> ExpandNoBranch (see, exp) | _ -> raise (Failure "Ill-formed borrow expansion")) - | T.TypeVar _ | T.Literal Char | Never | T.TraitType _ | T.Arrow _ -> + | T.TypeVar _ + | T.Literal Char + | Never | T.TraitType _ | T.Arrow _ | T.RawPtr _ -> raise (Failure "Ill-formed symbolic expansion") in Some (Expansion (place, sv, expansion)) diff --git a/compiler/TypesAnalysis.ml b/compiler/TypesAnalysis.ml index 16f8c5f9..38d350b1 100644 --- a/compiler/TypesAnalysis.ml +++ b/compiler/TypesAnalysis.ml @@ -168,6 +168,9 @@ let analyze_full_ty (r_is_static : 'r -> bool) (updated : bool ref) in (* Continue exploring *) analyze expl_info ty_info rty + | RawPtr (rty, _) -> + (* TODO: not sure what to do here *) + analyze expl_info ty_info rty | Adt ((Tuple | Assumed (Box | Slice | Array | Str)), generics) -> (* Nothing to update: just explore the type parameters *) List.fold_left diff --git a/compiler/dune b/compiler/dune index 4ec46b70..a4b09df4 100644 --- a/compiler/dune +++ b/compiler/dune @@ -92,4 +92,4 @@ -g ;-dsource -warn-error - -5-8-9-11-14-33-20-21-26-27-39))) + -5@8-9-11-14-33-20-21-26-27-39))) -- cgit v1.3.1